Results 1 to 7 of 7

Thread: Improving Speed Comparing Multiple Columns

  1. #1
    Junior Member
    Join Date
    Mar 2012
    Posts
    3
    Rep Power
    0

    Improving Speed Comparing Multiple Columns

    I would like to please get assistance to improving speed for this particular following code because I have between 10,000 to 20,000 records.
    In columns J and K are dates. In column L are integers.

    Code:
    Sub COMPAREMULTIPLECOLUMNS()
    
        Dim sh1 As Worksheet, sh2 As Worksheet
    
        Dim j As Long, i As Long, lastrow1 As Long, lastrow2 As Long
    
        Set sh1 = Worksheets("CURRENT")
    
        Set sh2 = Worksheets("PREVIOUS")
    
        
    
        lastrow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    
        lastrow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row
    
     
    
        For i = 2 To lastrow1
    
            For j = 2 To lastrow2
    
                If sh1.Cells(i, "F").Value = sh2.Cells(j, "F").Value Then
    
    		If sh1.Cells(i, "J").Value <> sh2.Cells(j, "J").Value Then		
    
                    sh1.Cells(i, "R").Value = sh2.Cells(j, "J").Value
    
                End If
    
    	    End If
    
    	    If sh1.Cells(i, "F").Value = sh2.Cells(j, "F").Value Then
    
    		If sh1.Cells(i, "K").Value <> sh2.Cells(j, "K").Value Then		
    
                    sh1.Cells(i, "S").Value = sh2.Cells(j, "K").Value
    
                End If
    		
    	    End If
    
    	    If sh1.Cells(i, "F").Value = sh2.Cells(j, "F").Value Then
    
    		If sh1.Cells(i, "L").Value <> sh2.Cells(j, "L").Value Then		
    
                    sh1.Cells(i, "T").Value = sh2.Cells(j, "L").Value
    
                End If
    
                End If
    
            Next j
    
        Next i
    
    End Sub
    I would greatly appreciate any assistance.

  2. #2
    Member
    Join Date
    Nov 2011
    Posts
    41
    Rep Power
    0
    Plese try this one.
    Code:
    Sub OptimzeSpeed()
    
        Dim varArrSheet1        As Variant
        Dim varArrSheet2        As Variant
        
        Dim lngCtr1             As Long
        Dim lngCtr2             As Long
        
        Const strSheetName1      As String = "CURRENT"
        Const strSheetName2      As String = "PREVIOUS"
        
        varArrSheet1 = ThisWorkbook.Worksheets(strSheetName1).UsedRange
        varArrSheet2 = ThisWorkbook.Worksheets(strSheetName2).UsedRange
        
        ThisWorkbook.Worksheets(strSheetName1).UsedRange.ClearContents
        
        
        For lngCtr1 = LBound(varArrSheet1) To UBound(varArrSheet1)
            For lngCtr2 = LBound(varArrSheet2) To UBound(varArrSheet2)
                If varArrSheet1(lngCtr1, 5) = varArrSheet1(lngCtr2, 5) Then
                    If varArrSheet1(lngCtr1, 10) <> varArrSheet1(lngCtr2, 10) Then
                        varArrSheet1(lngCtr1, 18) = varArrSheet1(lngCtr2, 10)
                    End If
                    
                    If varArrSheet1(lngCtr1, 11) <> varArrSheet1(lngCtr2, 11) Then
                        varArrSheet1(lngCtr1, 19) = varArrSheet1(lngCtr2, 11)
                    End If
                    
                    If varArrSheet1(lngCtr1, 12) <> varArrSheet1(lngCtr2, 12) Then
                        varArrSheet1(lngCtr1, 20) = varArrSheet1(lngCtr2, 12)
                    End If
                End If
            Next
        Next
        With ThisWorkbook.Worksheets(strSheetName1)
            .UsedRange.ClearContents
            .Range(A1).Resize(UBound(varArrSheet1, 1), UBound(varArrSheet1, 2)) = varArrSheet1
        End With
        
    End Sub
    Regards
    Prince

  3. #3
    Junior Member
    Join Date
    Mar 2012
    Posts
    3
    Rep Power
    0
    Thank you for your replay Prince. I get the subscript out of range error at this line.

    Code:
    If varArrSheet1(lngCtr1, 5) = varArrSheet1(lngCtr2, 5) Then

  4. #4
    Senior Member
    Join Date
    Jun 2012
    Posts
    337
    Rep Power
    12
    It would have been nice if you had described what the code should do under what conditions...

    Code:
    Sub M_snb()
        sn = Sheets("Current").Cells(1).CurrentRegion.Offset(, 5).Resize(, 15)
        sp = Sheets("Previous").Cells(1).CurrentRegion.Offset(, 5).Resize(, 15)
    
         With CreateObject("scripting.dictionary")
            For j = 1 To UBound(sn)
              .Item(sn(j, 1)) = Application.Index(sn, j, 0)
            Next
    
            For j = 1 To UBound(sp)
                 st = .Item(sp(j, 1))
                 st(13) = sp(j, 5)
                 st(14) = sp(j, 6)
                 st(15) = sp(j, 7)
                 .Item(sp(j, 1)) = Application.Index(st)
            Next
        
            Sheets("CURRENT").Cells(1).CurrentRegion.Offset(, 5).Resize(, 15) = Application.Index(.items, 0, 0)
        End With
    End Sub
    Last edited by snb; 10-01-2013 at 06:29 PM.

  5. #5
    Junior Member
    Join Date
    Mar 2012
    Posts
    3
    Rep Power
    0
    Thanks for replying snb. I'm trying to identify date and timeframe changes from one report to the next. I tried your code and got a compile error - "array is expected" on this piece of code.

    Code:
    For j = 1 To UBound(sn)

  6. #6
    Senior Member
    Join Date
    Jun 2012
    Posts
    337
    Rep Power
    12
    check
    - there are no empty cells in row 1 A1:T1
    - no empty cells in column A

  7. #7
    Member
    Join Date
    Nov 2011
    Posts
    41
    Rep Power
    0
    Hi Devid,


    Can you please share your workbook, So that we can provide you exact solution.

    Regards
    Prince

Similar Threads

  1. Concatenate Two Or Multiple Columns In To One
    By william516 in forum Excel Help
    Replies: 10
    Last Post: 07-06-2013, 12:09 AM
  2. Replies: 7
    Last Post: 05-15-2013, 02:56 PM
  3. Replies: 4
    Last Post: 04-05-2013, 12:08 PM
  4. Replies: 2
    Last Post: 06-14-2012, 04:10 AM
  5. Speed up Loop VBA
    By PcMax in forum Excel Help
    Replies: 15
    Last Post: 04-09-2012, 04:20 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •