Row match and alignment VBA code

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>

 

Some videos you may like

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

Amms123

New Member
Joined
Aug 3, 2019
Messages
15
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.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,117
Office Version
2007
Platform
Windows
Does this value "V-0001" exist twice in column B?
Or are all values ​​unique?
 

trunten

Active Member
Joined
Jul 26, 2011
Messages
479
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:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,117
Office Version
2007
Platform
Windows
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
 

Amms123

New Member
Joined
Aug 3, 2019
Messages
15
Hi DanteAmor, all the items are unique. I've just tried running your code and it works great

Muchas gracias senor
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,117
Office Version
2007
Platform
Windows
Hi DanteAmor, all the items are unique. I've just tried running your code and it works great

Muchas gracias senor

I'm glad to help you. Thanks for the feedback.
 

Amms123

New Member
Joined
Aug 3, 2019
Messages
15
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
 

Amms123

New Member
Joined
Aug 3, 2019
Messages
15
Hi DanteAmor

The error turned out to be duplicated rows in my data, so a simple fix.

Thx Amms123
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,117
Office Version
2007
Platform
Windows
So it already works for you?
 

Watch MrExcel Video

Forum statistics

Threads
1,102,050
Messages
5,484,411
Members
407,438
Latest member
DKrakken

This Week's Hot Topics

  • Finding issue in If elseif else with For each Loop
    Finding issue in If elseif else with For each Loop I have tried this below code but i'm getting in Y column filled with W005. Colud you please...
  • MsgBox Error
    Hi Guys, I have the below error show up when i try and run my macro in File1 but works fine if i copy and paste the same code into file2. [ATTACH...
  • CELL FORMAT - IF CONDITION
    My Cell Format is [B]""0.00" Cr". [/B]But in the cell, it is showing 123.00 for editing. (123 is entry figure). (Data imported from other...
  • Show numbers nearly the same
    Is this possible. I have a number that can change very time eg 0.00001234 Then I have a lot of numbers 0.0000001, 0.0000002, 0.00000004...
  • Please i need your help to create formula
    I need a formula in cell B8 to do this >>if b1=1 then multiply ( cell b8) by 10% ,if b1=2 multiply by 20%,if=3 multiply by 30%. Thank you in...
  • Got error while adding column and filter
    Got error while adding column and filter In column Z has some like "Success" and "Error". I want to add column in AA if the Z cell value is...
Top