Optimize Excel Code - Too many FOR NEXT Loops

Attached is latest. dmu123xls password still. Works great and does exactly what I want with a small dataset (it has loaded now just 3 cycles of the data)

I tried it with 500 cycles and could import both a before and after file (same file, I was just testing how long this would take) in about a minute each button.

Unfortunately the Compare button bombed and it just spun for at least 20 minutes before I ended it with task manager.

jindon, Is there anyway to optimize the part below that aligns the before and after rows? This was an essential part you helped me with on another post and works great with a small dataset. It may already be as efficient as possible and I'll need to lower my expectations as far as what is possible with vba.

'jindon code to align rows
    Dim a, b, c, e, s, i As Long, ii As Long, iii As Long, myStep As Long, x As Range, sd, ed
    Dim n As Long, w, flg As Boolean, LC As Long, LR As Long, myKey, myDesc, dic As Object
    Const keyCol As Long = 1, DescCol As Long = 3, idCol As Long = 2
    '? column setting form main key, description & id
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("Combined")
        LC = .Columns("BY").Column
        LR = .Cells.Find("*", , , , 1, 2).Row
        a = .Range("a1").Resize(LR, LC).Value2
        myStep = Application.RoundUp(LC / 2, 0)
    End With
    sd = DateAdd("yyyy", -30, Date): ed = DateAdd("yyyy", 10, Date)  '<--- adjust here
    For ii = 1 To UBound(a, 2) Step myStep
        For i = 1 To UBound(a, 1)
            myKey = a(i, ii + keyCol - 1)
            If myKey <> "" Then
                If Not dic.exists(myKey) Then
                    Set dic(myKey) = CreateObject("Scripting.Dictionary")
                End If
                myDesc = a(i, ii + DescCol - 1)
                If Not dic(myKey).exists(myDesc) Then
                    ReDim w(1 To UBound(a, 2) + 2, 1 To 1)
                Else
                    w = dic(myKey)(myDesc)
                End If
                n = w(UBound(w, 1) - IIf(ii = 1, 1, 0), 1) + 1
                If UBound(w, 2) < n Then ReDim Preserve w(1 To UBound(w, 1), 1 To n)
                For iii = ii To ii + myStep - 2
                    w(iii, n) = a(i, iii)
                Next
                w(UBound(w, 1) - IIf(ii = 1, 1, 0), 1) = n
                dic(myKey)(myDesc) = w
            End If
        Next
    Next
    ReDim a(1 To UBound(a, 1) * 2, 1 To UBound(a, 2)): n = 0
    For Each e In dic
        For Each s In dic(e)
        w = dic(e)(s)
            For ii = 1 To UBound(dic(e)(s), 2)
                n = n + 1
                For i = 1 To UBound(dic(e)(s), 1) - 2
                    a(n, i) = dic(e)(s)(i, ii)
                    If (a(n, i) >= sd) * (a(n, i) <= ed) Then
                        If x Is Nothing Then
                            Set x = Sheets("Aligned").Cells(n + 2, i)
                        Else
                            Set x = Union(x, Sheets("Aligned").Cells(n + 2, i))
                        End If
                    End If
                Next
            Next
        Next
    Next
    With Sheets("Aligned").[A3].Resize(n, UBound(a, 2))
        .Parent.UsedRange.Clear
        .Value = a
        If Not x Is Nothing Then x.NumberFormat = "m/d/yyyy hh:mm:ss AM/PM"
        .FormatConditions.Delete
        .FormatConditions.Add 2, , "=isnumber(search(""id"",$" & Replace(Cells(1, idCol).Address(0, 0), 1, "") & "3))"
        .FormatConditions(1).Interior.Color = RGB(225, 225, 225)
        .FormatConditions(1).Borders.LineStyle = xlContinuous
        .FormatConditions(1).Borders.Weight = xlThin
        .Cells.WrapText = True
        .Cells.Font.Name = "Calibri"
        .Cells.Font.Size = 7
        .Columns.ColumnWidth = 6.43
        .Rows.RowHeight = 8
    End With
'end jindon code