VBA : Compare, matching and offset set of data

greenbubble

New Member
Joined
Nov 13, 2022
Messages
7
Office Version
  1. 2003 or older
Hi,
Currently im using below VBA that is found in excel forum and its working fine for less data. I tried to run the VBA
for more than 2000 row of data it take some time to complete or most of the time it will crashed.

1 have 2 set of data:
1st set (Col:A,B,C,D)
2nd set Col:E,F,G,H)

I need to compare col A with col E data vise versa, matching by offset either 1st set or 2nd set.
i try to search for the solution and stuck with it. I expect help from you for my problem

Sub compare_c ()

Dim oLeft As Range
Dim oRight As Range

Set oLeft = Sheets("Summary").Range("A1,B1,C1,D1")
Set oRight = Sheets("Summary").Range("E1,F1,G1,H1")

Do Until oLeft.Value = "" Or oRight.Value = ""

If oLeft.Value = oRight.Value Then
Set oLeft = oLeft.Offset(1, 0)
Set oRight = oRight.Offset(1, 0)
ElseIf oLeft.Value > oRight.Value Then
oLeft.Insert Shift:=xlShiftDown
Set oRight = oLeft.Offset(0, 4)
Else
oRight.Insert Shift:=xlShiftDown
Set oLeft = oRight.Offset(0, -4)
End If
Loop

End Sub


mrExcel1.jpg
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Thanks for this (y) I see what you mean, it took me 4.5 minutes to run with your provided data. I have some ideas - leave it with me, it will take a while.
 
Upvote 0
Try this. Using the data you provided in post #11, it completed on my laptop in under 6 seconds. Let me know how you go.

VBA Code:
Option Explicit
Sub greenbubble_3()
    Application.ScreenUpdating = 0
    Application.Calculation = xlManual
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    Set ws = Worksheets("Summary")
    Dim LRow As Long, i As Long, j As Long, k As Long, m As Long, n As Long, x As Long
    LRow = ws.Range("A:D").Find("*", , xlFormulas, , 1, 2).Row
    
    Dim ArrIn, ArrValues
    ArrIn = ws.Range("A1:D" & LRow)
    ArrValues = ws.Range("E1", ws.Cells(Rows.Count, "E").End(xlUp))
    For i = 1 To UBound(ArrIn, 1)
        For j = 1 To UBound(ArrValues, 1)
            If ArrIn(i, 1) = ArrValues(j, 1) Then n = n + 1
        Next j
        If n = 0 Then n = 1
        x = x + n
        n = 0
    Next i
    
    Dim ArrOut
    ArrOut = ws.Range("A1:D" & x)
    k = 1
    n = 0
    x = 0
    For i = 1 To UBound(ArrIn, 1)
        For j = 1 To UBound(ArrValues, 1)
            If ArrIn(i, 1) = ArrValues(j, 1) Then n = n + 1
        Next j
        Select Case n
            Case Is = 0, 1
                For m = 1 To 4
                    ArrOut(k, m) = ArrIn(i, m)
                Next m
                k = k + 1
            Case Else
                For m = 1 To 4
                    ArrOut(k, m) = ArrIn(i, m)
                Next m
                For x = 1 To n - 1
                    k = k + 1
                    For m = 1 To 4
                        ArrOut(k, m) = ""
                    Next m
                Next x
                k = k + 1
        End Select
        n = 0
    Next i
    ws.Range("A1").Resize(UBound(ArrOut, 1), 4).Value = ArrOut
    
    LRow = ws.Cells(Rows.Count, 5).End(3).Row
    For i = 1 To LRow
        If ws.Cells(i, 1) <> "" And ws.Cells(i, 1) <> ws.Cells(i, 5) Then
            If WorksheetFunction.CountIf(Range("E:E"), ws.Cells(i, 1)) = 0 Then
                If ws.Cells(i, 1) > ws.Cells(i, 5) Then
                    ws.Cells(i, 1).Resize(, 4).Insert xlDown
                    Else
                    ws.Cells(i, 5).Resize(, 4).Insert xlDown
                End If
                Else
                    If WorksheetFunction.CountIf(Range("A:A"), ws.Cells(i, 5)) = 0 Then
                        ws.Cells(i, 1).Resize(, 4).Insert xlDown
                    End If
            End If
            LRow = LRow + 1
        End If
    Next i
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = 1
    MsgBox "Completed in " & Timer - t & " seconds."
End Sub
 
Upvote 0
Solution
Try this. Using the data you provided in post #11, it completed on my laptop in under 6 seconds. Let me know how you go.

VBA Code:
Option Explicit
Sub greenbubble_3()
    Application.ScreenUpdating = 0
    Application.Calculation = xlManual
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    Set ws = Worksheets("Summary")
    Dim LRow As Long, i As Long, j As Long, k As Long, m As Long, n As Long, x As Long
    LRow = ws.Range("A:D").Find("*", , xlFormulas, , 1, 2).Row
   
    Dim ArrIn, ArrValues
    ArrIn = ws.Range("A1:D" & LRow)
    ArrValues = ws.Range("E1", ws.Cells(Rows.Count, "E").End(xlUp))
    For i = 1 To UBound(ArrIn, 1)
        For j = 1 To UBound(ArrValues, 1)
            If ArrIn(i, 1) = ArrValues(j, 1) Then n = n + 1
        Next j
        If n = 0 Then n = 1
        x = x + n
        n = 0
    Next i
   
    Dim ArrOut
    ArrOut = ws.Range("A1:D" & x)
    k = 1
    n = 0
    x = 0
    For i = 1 To UBound(ArrIn, 1)
        For j = 1 To UBound(ArrValues, 1)
            If ArrIn(i, 1) = ArrValues(j, 1) Then n = n + 1
        Next j
        Select Case n
            Case Is = 0, 1
                For m = 1 To 4
                    ArrOut(k, m) = ArrIn(i, m)
                Next m
                k = k + 1
            Case Else
                For m = 1 To 4
                    ArrOut(k, m) = ArrIn(i, m)
                Next m
                For x = 1 To n - 1
                    k = k + 1
                    For m = 1 To 4
                        ArrOut(k, m) = ""
                    Next m
                Next x
                k = k + 1
        End Select
        n = 0
    Next i
    ws.Range("A1").Resize(UBound(ArrOut, 1), 4).Value = ArrOut
   
    LRow = ws.Cells(Rows.Count, 5).End(3).Row
    For i = 1 To LRow
        If ws.Cells(i, 1) <> "" And ws.Cells(i, 1) <> ws.Cells(i, 5) Then
            If WorksheetFunction.CountIf(Range("E:E"), ws.Cells(i, 1)) = 0 Then
                If ws.Cells(i, 1) > ws.Cells(i, 5) Then
                    ws.Cells(i, 1).Resize(, 4).Insert xlDown
                    Else
                    ws.Cells(i, 5).Resize(, 4).Insert xlDown
                End If
                Else
                    If WorksheetFunction.CountIf(Range("A:A"), ws.Cells(i, 5)) = 0 Then
                        ws.Cells(i, 1).Resize(, 4).Insert xlDown
                    End If
            End If
            LRow = LRow + 1
        End If
    Next i
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = 1
    MsgBox "Completed in " & Timer - t & " seconds."
End Sub
Kudos to you, brilliant.... it only take 2.5 sec, the solution help me a lot 👏👏👏👏👏
 
Upvote 0

Forum statistics

Threads
1,213,517
Messages
6,114,085
Members
448,548
Latest member
harryls

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top