Quantcast
Channel: Active questions tagged excel - Stack Overflow
Viewing all articles
Browse latest Browse all 88835

Improve the performance of excel vba while using search

$
0
0

I have 400 000 records in two sheets with 5 columns each with data in column A being the unique identifier. Order of the columns in both the sheets is same. I am trying to search for record that exists in Sheet1 and find it in Sheet2. If found, I need to compare the data of that record with the one in sheet2. Mismatched data should highlight the cells in sheet1 and copy the entire row in sheet 3.

My macro works successfully for small set of data but it gets hanged with large data and excel gets closed automatically.

I tried commenting the highlighting of cells and only copying the row and also separating only 25000 records but could see the same performance issue as stated earlier.

Sub CompareSheets()

    Dim wS As Worksheet, wT As Worksheet, RS As Worksheet
    Dim intSheet1Column As Integer, i As Long, j As Long, k As Long, FoundRow As Long

    Set wS = ThisWorkbook.Worksheets("Sheet1")
    Set wT = ThisWorkbook.Worksheets("Sheet2")
    Set RS = ThisWorkbook.Worksheets("Sheet3")

    RS.Cells.ClearContents
    RS.Cells.Interior.Color = RGB(255, 255, 255)
    wS.Rows(1).EntireRow.Copy RS.Range("A1")

    On Error Resume Next
    For i = 2 To wS.UsedRange.Rows.Count
       For j = 2 To wT.UsedRange.Rows.Count
       If InStr(1, wT.Range("A"& j).Value, wS.Range("A"& i).Value) > 0 Then
                Match = "FOUND"
                FoundRow = j
       Exit For
       End If
       Next


       If Match = "FOUND" Then
           CopyFlag = False
            For intSheet1Column = 2 To wS.UsedRange.Columns.Count
               If wS.Cells(i, intSheet1Column).Value <> wT.Cells(FoundRow, intSheet1Column).Value Then
                  wS.Cells(i, intSheet1Column).Interior.Color = RGB(255, 255, 0)
                  CopyFlag = True
                  k = RS.UsedRange.Rows.Count
               End If
            Next
                  If CopyFlag = True Then
                        wS.Rows(i).EntireRow.Copy RS.Range("A"& k + 1)
                  End If
       End If
    Next

    MsgBox "Validation Complete"
End Sub

Excel gets hanged and closes off automatically.


Viewing all articles
Browse latest Browse all 88835

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>