Row match and alignment VBA code

A

Amms123

New Member
Joined
Aug 3, 2019
Messages
15
I have a vba code I use to align and match column rows ofdata and up to about 200 rows of data it's been workingwithout any problems. However, I have encountered a problem when using it on severalhundred or thousands of rows of data.

Below is the code I am using to match and align the column rows of data: -


SubRowFormat()
Dim Rng AsRange
Dim Dn AsRange
Dim Dic1 AsObject
Set Rng =Range(Range("A2"), Range("A" &Rows.Count).End(xlUp)).Resize(, 2)
Set Dic1 =CreateObject("scripting.dictionary")
Dic1.CompareMode = vbTextCompare
For Each DnIn Rng
If Not Dic1.Exists(Dn.Value) Then
Dic1.Add Dn.Value, ""
Else
Dic1.Remove (Dn.Value)
End If
Next

For Each DnIn Rng
If Dn <> "" AndDic1.Exists(Dn.Value) Then
If Dn.Column = 1 Then
Dn.Offset(, 1).Insert
Else
Dn.Offset(, -1).Insert
End If
End If
Next Dn
Set Rng =Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
For Each DnIn Rng
If Not Dn = "" And NotDic1.Exists(Dn.Value) Then Dn.Offset(, 1) = Dn
Next Dn
End Sub

T
he data below is an example of the raw data with both columns sorted in ascending order before running the code.​

A-0001-T-01
A-0002-T-02
A-0002-V-01 A-0002-V-02
AH-01-V-0001 AX-00001
B-01-RG-01​
C-0002
E-00001A E-00002A
E-00002A

Below is the data after running the code, as you can see the second column has been aligned to match the first column and visa versa.
If there is no match it leaves a blank cell and goes onto the next row of data

A-0001-T-01
A-0002-T-02
A-0002-V-01
A-0002-V-02
AH-01-V-0001
AX-00001
B-01-RG-01
C-0002
E-00001A
E-00002A
E-00002A

However, a problem has occurred with the code when used on bigger amounts of data and below shows the match and alignment has failed for the rows 458 thru' 462, It then continues to correctly match and align the rows of data thereafter.

A further problem due to the miss-match in the second column is, the data has increased by 5 items, re the duplication of V-0001 thru' V-0005, as shown below in red font.


US-00-154
US-00-155 ​
​
V-0001​
​

US-00-156 ​
​
​
​
​
​
​
​
V-0002​
​
​
​
​

US-00-157 ​
​
​
V-0003​
​
​

US-00-158 ​
​
​
​
​
V-0004​
​
​
​
​

US-00-162 ​
​
​
V-0005​
​
​

V-0001 V-0001
V-0002 V-0002
V-0003 V-0003
V-0004 V-0004
V-0005 V-0005
V-0006 V-0006
V-0007 V-0007​
X-0001
X-0002

I would be grateful for any advice how to remedy this problem, or a better way to meet my objective consistently.

Thx

Amms123




​
​
<strike></strike>


<strike></strike>

<strike></strike>

 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
My apologies for my previous post for not following theappropriate protocol. I hope this amended post does and now clearly defines theproblem I have encountered.

The VBA code below is used to match and alignrows of data to their respective columns

Code: 
Sub RowFormat()
Dim Rng As Range
Dim Dn As Range
Dim Dic1 As Object
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)).Resize(, 2)
Set Dic1 = CreateObject("scripting.dictionary")
        Dic1.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not Dic1.Exists(Dn.Value) Then
        Dic1.Add Dn.Value, ""
    Else
        Dic1.Remove (Dn.Value)
    End If
Next[/FONT][/COLOR]


[COLOR=#000000]

[FONT=Calibri]For Each Dn In Rng
    If Dn <> "" And Dic1.Exists(Dn.Value) Then
        If Dn.Column = 1 Then
          Dn.Offset(, 1).Insert
        Else
            Dn.Offset(, -1).Insert
        End If
    End If
 Next Dn
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
For Each Dn In Rng
    If Not Dn = "" And Not Dic1.Exists(Dn.Value) Then Dn.Offset(, 1) = Dn
Next Dn
End Sub/code]



The example below shows the data for both columns sorted inascending order, before running the VBA code.
[FONT=Times New Roman][SIZE=3]
[/SIZE][/FONT]
[TABLE]
<tbody>[TR]
[TD]
[CENTER][CENTER]Column A[/CENTER]
[/CENTER]
[/TD]
[TD="width: 301, bgcolor: transparent"]
[CENTER][CENTER]Column B[/CENTER]
[/CENTER]
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]A-0001-T-01
[/TD]
[TD="width: 301, bgcolor: transparent"]A-0002-T-02
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]A-0001-T-02
[/TD]
[TD="width: 301, bgcolor: transparent"]A-0002-V-01
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]A-0002-V-01
[/TD]
[TD="width: 301, bgcolor: transparent"]A-0002-V-02
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]AH-01-V-0001
[/TD]
[TD="width: 301, bgcolor: transparent"]C-00002
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]B-01-RG-01
[/TD]
[TD="width: 301, bgcolor: transparent"]E-00002A
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]E-00001A
[/TD]
[TD="width: 301, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]E-00002A
[/TD]
[TD="width: 301, bgcolor: transparent"][/TD]
[/TR]
</tbody>[/TABLE]



The example below shows the rows matched and aligned withtheir respective columns after running the VBA code. If there is no matchbetween columns the code leaves a blank cell and goes to the next row of data.
[FONT=Times New Roman][SIZE=3]
[/SIZE][/FONT]
[TABLE]
<tbody>[TR]
[TD]
[CENTER][CENTER]Column A[/CENTER]
[/CENTER]
[/TD]
[TD="width: 301, bgcolor: transparent"]
[CENTER][CENTER]Column B[/CENTER]
[/CENTER]
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]A-0001-T-01
[/TD]
[TD="width: 301, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]A-0001-T-02
[/TD]
[TD="width: 301, bgcolor: transparent"]A-0002-T-02
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]A-0002-V-01
[/TD]
[TD="width: 301, bgcolor: transparent"]A-0002-V-01
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"][/TD]
[TD="width: 301, bgcolor: transparent"]A-0002-V-02
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]AH-01-V-0001
[/TD]
[TD="width: 301, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]B-01-RG-01
[/TD]
[TD="width: 301, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"][/TD]
[TD="width: 301, bgcolor: transparent"]C-00002
[/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]E-00001A
[/TD]
[TD="width: 301, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="width: 301, bgcolor: transparent"]E-00002A
[/TD]
[TD="width: 301, bgcolor: transparent"]E-00002A
[/TD]
[/TR]
</tbody>[/TABLE]


[/FONT][FONT=Times New Roman][SIZE=3]
[/SIZE][/FONT]
[FONT=Calibri][SIZE=3]However, I have encountered a problem with the VBA code whenused on larger amounts of data and below is an example where the match andalignment has failed for rows 458 thru’ to 462 but thereafter continues to correctlymatch and align the rows. Furthermore, column B data has now increased by 5items due to the mis-match and duplication of data.[/SIZE][/FONT]

[FONT=Times New Roman][SIZE=3]
[/SIZE][/FONT]
[TABLE]
<tbody>[TR]
[TD]
[CENTER][CENTER][FONT=Calibri][SIZE=3]Row#[/SIZE][/FONT][/CENTER]
[/CENTER]
[/TD]
[TD="width: 175, bgcolor: transparent"]
[CENTER][CENTER][FONT=Calibri][SIZE=3]Column A[/SIZE][/FONT][/CENTER]
[/CENTER]
[/TD]
[TD="width: 175, bgcolor: transparent"]
[CENTER][CENTER][FONT=Calibri][SIZE=3]Column B[/SIZE][/FONT][/CENTER]
[/CENTER]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]457[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]US-00-154[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]458[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]US-00-155[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][B][I][FONT=Calibri][SIZE=3]V-0001[/SIZE][/FONT][/I][/B]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]459[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]US-00-156[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][B][I][FONT=Calibri][SIZE=3]V-0002[/SIZE][/FONT][/I][/B]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]460[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]US-00-157[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][B][I][FONT=Calibri][SIZE=3]V-0003[/SIZE][/FONT][/I][/B]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]461[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]US-00-158[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][B][I][FONT=Calibri][SIZE=3]V-0004[/SIZE][/FONT][/I][/B]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]462[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]US-00-162[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][B][I][FONT=Calibri][SIZE=3]V-0005[/SIZE][/FONT][/I][/B]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]463[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0001[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0001[/SIZE][/FONT]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]464[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0002[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0002[/SIZE][/FONT]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]465[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0003[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0003[/SIZE][/FONT]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]466[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0004[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0004[/SIZE][/FONT]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]467[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0005[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0005[/SIZE][/FONT]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]468[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0006[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0006[/SIZE][/FONT]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]469[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0007[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]V-0007[/SIZE][/FONT]
[/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]470[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]X-0001[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="width: 66, bgcolor: transparent"][FONT=Calibri][SIZE=3]471[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][FONT=Calibri][SIZE=3]X-0002[/SIZE][/FONT]
[/TD]
[TD="width: 175, bgcolor: transparent"][/TD]
[/TR]
</tbody>[/TABLE]


[/COLOR]I would be extremely grateful for any advice you can provide, on how to remedy this problem.
 
Upvote 0
Does this value "V-0001" exist twice in column B?
Or are all values ​​unique?
 
Upvote 0
Is it important to preserve the order?
If not this would do it:

Code: 
Sub alignRows()
    Dim colA As Object, colB As Object
    Dim rawData() As Variant, matched() As Variant
    Dim k As Variant, v As Variant
    Dim sht As Worksheet
    
    Set sht = ActiveSheet
    
    Set colA = CreateObject("Scripting.Dictionary")
    colA.CompareMode = vbTextCompare
    Set colB = CreateObject("Scripting.Dictionary")
    colB.CompareMode = vbTextCompare
    With sht.Range("A2", sht.Cells(Application.Max(sht.Cells(sht.Rows.Count, 1).End(xlUp).Row, sht.Cells(sht.Rows.Count, 2).End(xlUp).Row), 2))
        If .Cells(1, 1).Row = 1 Then
            Exit Sub
        Else
            rawData = .Value
        End If
    End With
    For i = 1 To UBound(rawData)
        If LenB(rawData(i, 1)) Then colA.add rawData(i, 1), False
        If LenB(rawData(i, 2)) Then colB.add rawData(i, 2), False
    Next i
    For Each k In colA.keys
        If colB.exists(k) Then
            colB.remove k
            colA.Item(k) = True
        End If
    Next k
    ReDim matched(1 To colA.Count + colB.Count + 1, 1 To 2)
    i = 1
    matched(i, 1) = sht.Range("A1").Value
    matched(i, 2) = sht.Range("B1").Value
    For Each k In colA.keys
        i = i + 1
        matched(i, 1) = k
        If colA(k) Then matched(i, 2) = k
    Next k
    For Each k In colB.keys
        i = i + 1
        matched(i, 2) = k
    Next k
    Sheets.add(after:=Sheets(Sheets.Count)).Range("A1:B1").Resize(UBound(matched)).Value = matched
    Erase rawData
    Erase matched
    Set colA = Nothing
    Set colB = Nothing
    Set sht = Nothing
End Sub
 
Last edited:
Upvote 0
If the values ​​are unique, then try this macro. I did the test with 3000 records and the result is immediate.

Code: 
Sub match_alignment()
  Dim c As Range, r As Range, f As Range, cell As String, lr As Long
  Application.ScreenUpdating = False
  Range("C:D").ClearContents
  Range("A:A").Copy Range("C:C")
  For Each c In Range("B2", Range("B" & Rows.Count).End(xlUp))
    Set f = Range("C:C").Find(c, , xlValues, xlWhole)
    If Not f Is Nothing Then
      f.Offset(, 1) = c
    Else
      lr = Range("C" & Rows.Count).End(xlUp)(2).Row
      Range("C" & lr).Value = c
      Range("D" & lr).Value = "x"
    End If
  Next
  Range("C:D").Sort key1:=Range("C1"), order1:=xlAscending, Header:=xlYes
  Set r = Range("D2", Range("D" & Rows.Count).End(xlUp))
  Set f = r.Find("x", , xlValues, xlWhole)
  On Error Resume Next
  If Not f Is Nothing Then
      cell = f.Address
      Do
          f.Value = f.Offset(, -1).Value
          f.Offset(, -1).Value = ""
          Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
  End If
  Application.ScreenUpdating = True
  MsgBox "End"
End Sub
 
Upvote 0
Hi DanteAmor

On some data I'm using the code to align the rows, I am getting the following run-time error '457' - "The key is already associated with an element of this collection."

When debugging, the code stops at the point highlighted below in red

For i = 1 To UBound(rawData)
IfLenB(rawData(i, 1)) Then colA.Add rawData(i, 1), False
IfLenB(rawData(i, 2)) Then colB.Add rawData(i, 2), False

Any help you can provided on this glitch would be appreciated.

Thx Amms123
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Index Match w/ ISNUMBER(FIND ?
Replies
2
Views
183
SnKeaK
S
M
  • Solved
COUNTIF to count cells with conditional formatting
Replies
8
Views
1K
Peter_SSs
Peter_SSs
W
  • Solved
VBA - Match two values from Table1 to two in Table2 and move/align
2
Replies
15
Views
374
Welshy1491
W
L
  • Solved
vba code to search and clear contents
Replies
4
Views
245
londa_vba
L
M
  • Question Question
Conditional Formatting/Moving Rows Based on Matching and Opposite Data
Replies
1
Views
278
Madam_Xavier
M

Forum statistics

Threads
1,224,823
Messages
6,181,178
Members
453,021
Latest member
Justyna P

Share this page

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