Row match and alignment VBA code
Page 1 of 2 12 LastLast
Results 1 to 10 of 12

Thread: Row match and alignment VBA code

  1. #1
    New Member
    Join Date
    Aug 2019
    Posts
    15
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Row match and alignment VBA code

    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












  2. #2
    New Member
    Join Date
    Aug 2019
    Posts
    15
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Row match and alignment VBA code

    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





    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.


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



    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.


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




    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.



    Row#
    Column A
    Column B
    457 US-00-154
    458 US-00-155 V-0001
    459 US-00-156 V-0002
    460 US-00-157 V-0003
    461 US-00-158 V-0004
    462 US-00-162 V-0005
    463 V-0001 V-0001
    464 V-0002 V-0002
    465 V-0003 V-0003
    466 V-0004 V-0004
    467 V-0005 V-0005
    468 V-0006 V-0006
    469 V-0007 V-0007
    470 X-0001
    471 X-0002


    I would be extremely grateful for any advice you can provide, on how to remedy this problem.

  3. #3
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,668
    Post Thanks / Like
    Mentioned
    64 Post(s)
    Tagged
    14 Thread(s)

    Default Re: Row match and alignment VBA code

    Does this value "V-0001" exist twice in column B?
    Or are all values ​​unique?
    Regards Dante Amor

  4. #4
    Board Regular
    Join Date
    Jul 2011
    Posts
    475
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Row match and alignment VBA code

    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 by trunten; Aug 29th, 2019 at 11:14 AM.

  5. #5
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,668
    Post Thanks / Like
    Mentioned
    64 Post(s)
    Tagged
    14 Thread(s)

    Default Re: Row match and alignment VBA code

    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
    Regards Dante Amor

  6. #6
    New Member
    Join Date
    Aug 2019
    Posts
    15
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Row match and alignment VBA code

    Hi DanteAmor, all the items are unique. I've just tried running your code and it works great

    Muchas gracias senor

  7. #7
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,668
    Post Thanks / Like
    Mentioned
    64 Post(s)
    Tagged
    14 Thread(s)

    Default Re: Row match and alignment VBA code

    Quote Originally Posted by Amms123 View Post
    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.
    Regards Dante Amor

  8. #8
    New Member
    Join Date
    Aug 2019
    Posts
    15
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Row match and alignment VBA code

    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

  9. #9
    New Member
    Join Date
    Aug 2019
    Posts
    15
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Row match and alignment VBA code

    Hi DanteAmor

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

    Thx Amms123

  10. #10
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,668
    Post Thanks / Like
    Mentioned
    64 Post(s)
    Tagged
    14 Thread(s)

    Default Re: Row match and alignment VBA code

    So it already works for you?
    Regards Dante Amor

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

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