Optimize Excel Code - Too many FOR NEXT Loops

Hi All, Attached is a macro-enabled workbook with a lot of For Next Loops. Run speed is mostly bearable except for the Summarize button which calls a Summarize Sub. Its actually 3 Subs strung together with Two Calls between them -Summarize, Summarize2, Summarize3. The gist of this application is that the user runs through the buttons on the Main worksheet in order from left to right. It all starts with Importing a Before and After html file, then comparing them for differences. I would supply the two files, but we can't upload that file type apparently.

Anyway, I'm a novice with VBA. Love it and I certainly see its huge potential, but I mostly have to steal code (or beg help) and modify to fit my situation. Could someone with more experience give me any tips to speed up the code? Again, its mainly the Summarize Subs with SOOOOO many For Next loops. Is there a better way? Password for the vba module is dmu123xls.

Thank you, tdsg

Originally Posted by tdsg

I would supply the two files, but we can't upload that file type apparently.

Hi,

as it's not difficult to add a valid extension at the end of the filename like .txt …

I zipped the two files. Good idea on using a different file type!

All the code works, just too slow especially when you click on the Summarize button. The other buttons run in less than about 15 seconds each, but the Summarize one takes 2-3 minutes and is what populates the Summary worksheet.

Yep, i was afraid that would be missed in the last sentence of my post. Should have highlighted it, The password is dmu123xls.

tdsg

I know, apologies. That part was done by Forum Guru, jindon and is way beyond my capabilities. I could barely read it to tweak it. He figured out how to get the rows to align when records (rows) were either added or deleted between the before and after parts. Otherwise, comparing would be easy since all the columns would line up on the same rows if edits to existing data (rows) was all that was done. Hope this makes sense. I'm not good at adding comments either for all the For Next loops. The Compare worksheet shows all the rows and turns red anything that changed. The Summary worksheet is where i'm trying to show only the rows that turned red where something changed (delete row, add row, or change data in existing row).

I'm sorry. Not the Compare worksheet. Meant to say the Main worksheet shows all the rows and turns red anything that changed.

Your loops are hopeless...
e.g.

Dim Cell As Range
For Each Cell In ThisWorkbook.Worksheets("Main").Range("A:A")
If Cell.Value Like "*Rec ID" Then Cell.Font.Color = vbBlue
Next Cell

For Each Cell In ThisWorkbook.Worksheets("Main").Range("A:A")
If Cell.Value Like "*Rec ID" Then Cell.Font.Bold = True
Next Cell

You are looping entire column...
Find method.
eg

Sub Formatting_click()

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim Cell As Range, ff As String
With ThisWorkbook.Sheets("main")
    With .Columns("a")
        Set Cell = .Find("*Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                Cell.Font.Color = vbBlue
                Cell.Font.Bold = True
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
        Set Cell = .Find("Data Mapunit Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                With Cell(2)
                    .Font.Bold = True
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.Color = RGB(255, 255, 0)
                End With
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
    End With
    .Range("A1:AK2").Interior.Color = RGB(255, 255, 0)
    .Range("AM1:BX2").Interior.Color = RGB(128, 255, 0)
    .Range("A1").Value = "DMU-COMPARE-TOOL"
    .Range("A1").Font.Color = vbBlue
    .Range("A1").Font.Bold = True
    .Range("A1:BX2").Cells.WrapText = False

Lastrow = ThisWorkbook.Worksheets("After").Cells(Rows.Count, "A").End(xlUp).Row
Dim r As Long, rr As Long

    For r = 3 To Lastrow
        For rr = 1 To 37
            If rr = 1 Then
                If .Cells(r, rr).Value Like "" Then .Cells(r, 1).Value = "Deleted"
            End If
            If .Cells(r, rr).Value <> .Cells(r, rr + 38).Value Then .Cells(r, rr).Font.Color = vbRed
        Next
    Next r
    Dim myCols, myVals, x, y
    myCols = Array(19, 33, "3:14")
    myVals = Array("FL Ecol Comm *", "SIR*", Array("*4 L", "*4 R", "*4 H", "*10 L", "*10 R", _
                        "*10 H", "*40 L", "*40 R", "*40 H", "*200 L", "*200 R", "*200 H"))
    For r = 0 To UBound(myCols)
        If r < 2 Then
            x = Split(myCols(r), ":")
            y = Split(myVals(r), ":")
        Else
            x = Evaluate("transpose(row(" & myCols(r) & "))")
            ReDim Preserve x(0 To UBound(x) - 1)
            y = myVals(2)
        End If
        For rr = 0 To UBound(x)
            Set Cell = .Columns(Val(x(rr))).Find(y(rr), , , 1)
            If Not Cell Is Nothing Then
                ff = Cell.Address
                Do
                    Cell.Font.Color = vbBlack
                    Set Cell = .Columns(Val(x(rr))).FindNext(Cell)
                Loop Until ff = Cell.Address
                Set Cell = Nothing
            End If
        Next
    Next
    .Select
    .Range("A4").Select
End With
Call ProtectAllSheets

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = Empty
End With

End Sub

You also need to review "Sub Summarize_click()"

Amazing code, jindon. Thank you so much. Incorporated with slight tweaks to formatting (some color changes0. Is there a way to also turn red the font in columns AM to BW? You know, the ones that are counterparts to the ones turned red in columns A to AK. Its nice to be able to scroll right and quickly locate what the values were before edits.

Presently, all the Summarize button does is to copy the Main worksheet over to the Summary worksheet. What I need it to do is only show rows that have something red in it and the column header for that. Earlier I successfully did this with an insane amount of For Next loops. I have since deleted that because it is too slow and this was the reason for this post. Do you know how to accomplish this for rows 3 to lastrow on the Summary worksheet? Since there are so many rows on the Main worksheet, its a lot to scroll through to find the red ones that changed. That is why I want to show only the rows with some red and their headers on the Summary worksheet. Hope this makes sense. Latest workbook attached. Module password is the same - dmu123xls.

tdsg

Shutdown my pc already, so I will have a look at it sometime tomorrow.

You're awesome, jindon. I'm sure you recognized the Align Sub code that you helped me with in another post. Thank you for taking an interest in this application and helping me so much. Believe it or not, I am learning a lot with help from people like you on this forum. I do struggle to read or modify your code though - too advanced for me, ha. Any further help you can provide at your convenience will be a blessing to me. Cheers!

Too many lines delete/add/changed etc...
Try the attached ans see how it goes.

I disabled ProtectAll for testing porpose.

Hey jindon, thank you! I got an error on this line of code for the Compare Sub.

If Not rng2 Is norhing Then Set rng1 = Union(rng1, rng2)

I could not try out the Summarize code. Do you know the issue with the above? I cleared all then imported both files, then clicked the Compare button and got the error.

Oops, typo
should read as Nothing.

If Not rng2 Is Nothing Then Set rng1 = Union(rng1, rng2)

I am so pleased with your help, jindon. Both worksheets, Main and Summary, do what I want them to do because of your talents. Users can see everything, changes or not, on the Main worksheet. They can also see a lot fewer rows (less scrolling) on the Summary worksheet with changes only. Perfect! I'll try testing this out with a larger import and see what the wait time is for each button. I fear that some of these datasets could be quite large and the code will bog down. We'll see though. It might be okay. I'll mark this as solved since my code has been optimized, or is at least soooo much faster than when I had all those For Next loops.

Attaching the final code and the before and after text files in case this is useful to anyone else with similar needs that could modify.

module password is still dmu123xls

Cheers!

Used CF to avoid slow loop

Sub Formatting_click()

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With





'jindon code
Dim Cell As Range, ff As String
With ThisWorkbook.Sheets("main")
    With .Columns("a")
        Set Cell = .Find("*Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                Cell.Font.Color = RGB(65, 105, 225)
                Cell.Font.Bold = True
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
        Set Cell = .Find("Data Mapunit Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                With Cell(2)
                    .Font.Bold = True
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.Color = RGB(255, 255, 204)
                End With
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
    End With
    .Range("A1:AK2").Interior.Color = RGB(255, 255, 204)
    .Range("AM1:BX2").Interior.Color = RGB(204, 255, 204)
    .Range("A1").Value = "DMU-COMPARE-TOOL"
    .Range("A1").Font.Color = RGB(65, 105, 225)
    .Range("A1").Font.Bold = True
    .Range("A1:BX2").Cells.WrapText = False

    Lastrow = ThisWorkbook.Worksheets("Main").Cells(Rows.Count, "A").End(xlUp).Row
    With .Range("b3:ak" & Lastrow)
        .FormatConditions.Delete
        .FormatConditions.Add 2, , "=b3<>an3"
        .FormatConditions(1).Font.Color = vbRed
        With .Offset(, 38)
            .FormatConditions.Delete
            .FormatConditions.Add 2, , "=an2<>b2"
            .FormatConditions(1).Font.Color = vbRed
        End With
    End With
    Dim myCols, myVals, x, y
    myCols = Array(19, 33, "3:14")
    myVals = Array("FL Ecol Comm *", "SIR*", Array("*4 L", "*4 R", "*4 H", "*10 L", "*10 R", _
                        "*10 H", "*40 L", "*40 R", "*40 H", "*200 L", "*200 R", "*200 H"))
    For r = 0 To UBound(myCols)
        If r < 2 Then
            x = Split(myCols(r), ":")
            y = Split(myVals(r), ":")
        Else
            x = Evaluate("transpose(row(" & myCols(r) & "))")
            ReDim Preserve x(0 To UBound(x) - 1)
            y = myVals(2)
        End If
        For rr = 0 To UBound(x)
            Set Cell = .Columns(Val(x(rr))).Find(y(rr), , , 1)
            If Not Cell Is Nothing Then
                ff = Cell.Address
                Do
                    Cell.Font.Color = vbBlack
                    Set Cell = .Columns(Val(x(rr))).FindNext(Cell)
                Loop Until ff = Cell.Address
                Set Cell = Nothing
            End If
        Next
    Next
    .Select
    .Range("A4").Select
End With
'end jindon code


'Call ProtectAllSheets

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = Empty
End With

End Sub

Any speed enhancements will be huge. The sample before and after files are tiny compared to what they will be. Unfortunately, the code above caused me to loose the gray header interior colors on all columns except A and AM.

OK change to

Sub Formatting_click()

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With





'jindon code
Dim Cell As Range, ff As String
With ThisWorkbook.Sheets("main")
    With .Columns("a")
        Set Cell = .Find("*Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                Cell.Font.Color = RGB(65, 105, 225)
                Cell.Font.Bold = True
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
        Set Cell = .Find("Data Mapunit Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                With Cell(2)
                    .Font.Bold = True
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.Color = RGB(255, 255, 204)
                End With
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
    End With
    .Range("A1:AK2").Interior.Color = RGB(255, 255, 204)
    .Range("AM1:BX2").Interior.Color = RGB(204, 255, 204)
    .Range("A1").Value = "DMU-COMPARE-TOOL"
    .Range("A1").Font.Color = RGB(65, 105, 225)
    .Range("A1").Font.Bold = True
    .Range("A1:BX2").Cells.WrapText = False

    Lastrow = ThisWorkbook.Worksheets("Main").Cells(Rows.Count, "A").End(xlUp).Row
    .Cells.FormatConditions.Delete
    With .Range("a3:ak" & Lastrow)
        .FormatConditions.Add 2, , "=isnumber(search(""id"",$a3))"
        .FormatConditions(1).Interior.Color = RGB(225, 225, 225)
        .FormatConditions(1).Borders.LineStyle = xlContinuous
        .FormatConditions(1).Borders.Weight = xlThin
    End With
    With .Range("b3:ak" & Lastrow)
        .FormatConditions.Add 2, , "=b3<>an3"
        .FormatConditions(2).Font.Color = vbRed
        With .Offset(, 38)
            .FormatConditions.Add 2, , "=an2<>b2"
            .FormatConditions(1).Font.Color = vbRed
        End With
    End With
    Dim myCols, myVals, x, y
    myCols = Array(19, 33, "3:14")
    myVals = Array("FL Ecol Comm *", "SIR*", Array("*4 L", "*4 R", "*4 H", "*10 L", "*10 R", _
                        "*10 H", "*40 L", "*40 R", "*40 H", "*200 L", "*200 R", "*200 H"))
    For r = 0 To UBound(myCols)
        If r < 2 Then
            x = Split(myCols(r), ":")
            y = Split(myVals(r), ":")
        Else
            x = Evaluate("transpose(row(" & myCols(r) & "))")
            ReDim Preserve x(0 To UBound(x) - 1)
            y = myVals(2)
        End If
        For rr = 0 To UBound(x)
            Set Cell = .Columns(Val(x(rr))).Find(y(rr), , , 1)
            If Not Cell Is Nothing Then
                ff = Cell.Address
                Do
                    Cell.Font.Color = vbBlack
                    Set Cell = .Columns(Val(x(rr))).FindNext(Cell)
                Loop Until ff = Cell.Address
                Set Cell = Nothing
            End If
        Next
    Next
    .Select
    .Range("A4").Select
End With
'end jindon code


'Call ProtectAllSheets

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = Empty
End With

End Sub

Hi jindon, That definitely helped. It added back in the gray headers for columns A through AK. I added a WITH after yours for columns AM3 to BW and lastrow (bold below) to get the gray headers for those, but for some reason, the fonts are all turning red in those columns. I'm just not skilled enough to edit your code with any degree of confidence that i did not mess it up.

'jindon code
Dim Cell As Range, ff As String
With ThisWorkbook.Sheets("main")
    With .Columns("a")
        Set Cell = .Find("*Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                Cell.Font.Color = RGB(65, 105, 225)
                Cell.Font.Bold = True
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
        Set Cell = .Find("Data Mapunit Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                With Cell(2)
                    .Font.Bold = True
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.Color = RGB(255, 255, 204)
                End With
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
    End With
    .Range("A1:AK2").Interior.Color = RGB(255, 255, 204)
    .Range("AM1:BX2").Interior.Color = RGB(204, 255, 204)
    .Range("A1").Value = "DMU-COMPARE-TOOL"
    .Range("A1").Font.Color = RGB(65, 105, 225)
    .Range("A1").Font.Bold = True
    .Range("A1:BX2").Cells.WrapText = False

    Lastrow = ThisWorkbook.Worksheets("Main").Cells(Rows.Count, "A").End(xlUp).Row
    .Cells.FormatConditions.Delete
    With .Range("a3:ak" & Lastrow)
        .FormatConditions.Add 2, , "=isnumber(search(""id"",$a3))"
        .FormatConditions(1).Interior.Color = RGB(225, 225, 225)
        .FormatConditions(1).Borders.LineStyle = xlContinuous
        .FormatConditions(1).Borders.Weight = xlThin
    End With
    With .Range("am3:bw" & Lastrow)
        .FormatConditions.Add 2, , "=isnumber(search(""id"",$am3))"
        .FormatConditions(1).Interior.Color = RGB(225, 225, 225)
        .FormatConditions(1).Borders.LineStyle = xlContinuous
        .FormatConditions(1).Borders.Weight = xlThin
    End With
    With .Range("b3:ak" & Lastrow)
        .FormatConditions.Add 2, , "=b3<>an3"
        .FormatConditions(2).Font.Color = vbRed
        With .Offset(, 38)
            .FormatConditions.Add 2, , "=an2<>b2"
            .FormatConditions(1).Font.Color = vbRed
        End With
    End With
    Dim myCols, myVals, x, y
    myCols = Array(19, 33, "3:14")
    myVals = Array("FL Ecol Comm *", "SIR*", Array("*4 L", "*4 R", "*4 H", "*10 L", "*10 R", _
                        "*10 H", "*40 L", "*40 R", "*40 H", "*200 L", "*200 R", "*200 H"))
    For r = 0 To UBound(myCols)
        If r < 2 Then
            x = Split(myCols(r), ":")
            y = Split(myVals(r), ":")
        Else
            x = Evaluate("transpose(row(" & myCols(r) & "))")
            ReDim Preserve x(0 To UBound(x) - 1)
            y = myVals(2)
        End If
        For rr = 0 To UBound(x)
            Set Cell = .Columns(Val(x(rr))).Find(y(rr), , , 1)
            If Not Cell Is Nothing Then
                ff = Cell.Address
                Do
                    Cell.Font.Color = vbBlack
                    Set Cell = .Columns(Val(x(rr))).FindNext(Cell)
                Loop Until ff = Cell.Address
                Set Cell = Nothing
            End If
        Next
    Next
    .Select
    .Range("A4").Select
End With
'end jindon code

Hope this one is ok

Sub Formatting_click()

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With





'jindon code
Dim Cell As Range, ff As String
With ThisWorkbook.Sheets("main")
    With .Columns("a")
        Set Cell = .Find("*Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                Cell.Font.Color = RGB(65, 105, 225)
                Cell.Font.Bold = True
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
        Set Cell = .Find("Data Mapunit Rec ID", , , 1)
        If Not Cell Is Nothing Then
            ff = Cell.Address
            Do
                With Cell(2)
                    .Font.Bold = True
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.Color = RGB(255, 255, 204)
                End With
                Set Cell = .FindNext(Cell)
            Loop Until ff = Cell.Address
            Set Cell = Nothing
        End If
    End With
    .Range("A1:AK2").Interior.Color = RGB(255, 255, 204)
    .Range("AM1:BX2").Interior.Color = RGB(204, 255, 204)
    .Range("A1").Value = "DMU-COMPARE-TOOL"
    .Range("A1").Font.Color = RGB(65, 105, 225)
    .Range("A1").Font.Bold = True
    .Range("A1:BX2").Cells.WrapText = False

    Lastrow = ThisWorkbook.Worksheets("Main").Cells(Rows.Count, "A").End(xlUp).Row
    With .Range("b3:ak" & Lastrow)
        .FormatConditions.Add 2, , "=b3<>an3"
        .FormatConditions(2).Font.Color = vbRed
        With .Offset(, 38)
            .FormatConditions.Add 2, , "=an2<>b2"
            .FormatConditions(2).Font.Color = vbRed
        End With
    End With
    Dim myCols, myVals, x, y
    myCols = Array(19, 33, "3:14")
    myVals = Array("FL Ecol Comm *", "SIR*", Array("*4 L", "*4 R", "*4 H", "*10 L", "*10 R", _
                        "*10 H", "*40 L", "*40 R", "*40 H", "*200 L", "*200 R", "*200 H"))
    For r = 0 To UBound(myCols)
        If r < 2 Then
            x = Split(myCols(r), ":")
            y = Split(myVals(r), ":")
        Else
            x = Evaluate("transpose(row(" & myCols(r) & "))")
            ReDim Preserve x(0 To UBound(x) - 1)
            y = myVals(2)
        End If
        For rr = 0 To UBound(x)
            Set Cell = .Columns(Val(x(rr))).Find(y(rr), , , 1)
            If Not Cell Is Nothing Then
                ff = Cell.Address
                Do
                    Cell.Font.Color = vbBlack
                    Set Cell = .Columns(Val(x(rr))).FindNext(Cell)
                Loop Until ff = Cell.Address
                Set Cell = Nothing
            End If
        Next
    Next
    .Select
    .Range("A4").Select
End With
'end jindon code


'Call ProtectAllSheets

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = Empty
End With

End Sub

Much better as far as applying the correct formatting to the header rows versus data rows (gray/white). But, for some reason the red cells are not matching up between columns A-AK and AM:BW when I scroll right to see what the value was before changes.

I figured it out. Changed this

    Lastrow = ThisWorkbook.Worksheets("Main").Cells(Rows.Count, "A").End(xlUp).Row
    With .Range("b3:ak" & Lastrow)
        .FormatConditions.Add 2, , "=b3<>an3"
        .FormatConditions(2).Font.Color = vbRed
        With .Offset(, 38)
            .FormatConditions.Add 2, , "=an2<>b2"
            .FormatConditions(2).Font.Color = vbRed
        End With
    End With

To this

Lastrow = ThisWorkbook.Worksheets("Main").Cells(Rows.Count, "A").End(xlUp).Row
    With .Range("a3:ak" & Lastrow)
        .FormatConditions.Add 2, , "=a3<>am3"
        .FormatConditions(2).Font.Color = vbRed
        With .Offset(, 38)
            .FormatConditions.Add 2, , "=am3<>a3"
            .FormatConditions(2).Font.Color = vbRed
        End With
    End With

See.. I'm learning enough to help myself a little. Thanks again, jindon, for all the help.

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

Alright, thank you. I tried 100 cycles of data which amounted to 57,000 rows and the Compare button ran in about 90 seconds. I wish it would handle more, but, if its the formatting code that slows it down, i don't know of a way around that.

I imported html files initially, but switched to text files later thinking that was faster. I'm wondering if I should switch back to html files that include formatting so that the only formatting I need to do with vba is to turn them red when different. Maybe I can pursue this and see where that goes.