compare 2 columns and shift columns down or up until the line matches

Hi everyone.

I have attached a file with operator numbers in columns A and B. I am looking for some VB code which compares A to B and shifts down column B a number of times until the values match. Also, likewise compare B to A so that it matches. If any values do not match then just a blank cell needs to be inserted in either column A or column B to shift the cells down until they match.

I hope I have explained that and the attached file helps.

Thanks


Ps - I have amended the attached file to make it clearer hopefully what I am looking for

test.xlsx

Here is a three step formula based process.
1. Produce a list of unique values using the array formula**: =INDIRECT(TEXT(MIN(IF((A$2:B$16<>"")*(COUNTIF(D$1:D1,A$2:B$16)=0),ROW(A$2:B$16)*100+COLUMN(A$2:B$16),6553601)),"R0C00"),0)+0
2. Sort the unique list smallest to greatest using: =SMALL(D$2:D$22,ROWS(F$2:F2))
3. Display the result using: =IF(ISNUMBER(MATCH($F2,A$2:A$16,0)),$F2,"")
**Array formulas are not entered in the same way as 'standard' formulas. Instead of pressing just ENTER, you first hold down CTRL and SHIFT, and only then press ENTER. If you've done it correctly, you'll notice Excel puts curly brackets {} around the formula (though do not attempt to manually insert these yourself).
Note that as you are using the 365 version it may not be necessary to activate the formula for #1 using CSE.
Let us know if you have any questions.

new example.xlsm

Hi. Thanks for the reply. I have added a new file as an example with sensitive data deleted out but hopefully this will give you more of an idea of what I would like. So, basically, the data in both the tabs need to be
side by side so you would have columns A to E from 'Today' then a blank column in F then columns A to E from 'Yesterday'. Then I need to compare column B to H, C to I and D to J. And the rows (cells) moving down
until the numbers match. Or leave a blank line and shift down cells until either B = H or C = I

Thanks

Hi. I was trying to provide an example of the file / data without providing the full file due to sensitive data in it. I was hoping I would then be able to provide the logic in the solution to the three columns.

So, the data in Today and Yesterday need to go into a new tab. The data from Today columns A to E first then a blank column in column F. Then the data from Yesterday columns A to E copied into the new tab in columns G to K.

I need to compare column B to H, then C to I and D to J. the rows (cells) moving down until either the 3 columns match or if C = I and D = J . it is possible that C=I and D=J but B does not equal H and these can all stay lined up on the same row.

You may get details on the left hand side but not the right and I would just like blank cells from column G onwards (moving down the cells probably). Likewise, there may be records from columns G to J which dont match up to columns B to D. In this case I would like the data in columns on the left hand side moving down so there is just a blank line as the data doesnt match.

I dont know if this is possible in VBA but if anyone can provide something that would be great.

Regards

new example.xlsm

BryanRobson,

try

Sub test()
    Dim a, b, e, x(1), w, s As String, dic As Object
    Dim i As Long, ii As Long, iii As Long, n As Long, t As Long
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    If Not [isref(results!a1)] Then Sheets.Add(Sheets(1)).Name = "results"
    With Sheets("results")
        .UsedRange.Clear
        Sheets("today").[a1].CurrentRegion.EntireColumn.Copy .[a1]
        Sheets("yesterday").[a1].CurrentRegion.EntireColumn.Copy .[f1]
        a = Intersect(.UsedRange.Offset(1), .Columns("a:i")).Value
        For ii = 1 To UBound(a, 2) Step 5
            For i = 1 To UBound(a, 1)
                If a(i, ii) <> "" Then
                    s = ""
                    For iii = ii + 1 To ii + 3
                        s = s & Chr(2) & a(i, iii)
                    Next
                    If Not dic.exists(s) Then
                        ReDim w(1 To 2)
                    Else
                        w = dic(s)
                    End If
                    w(IIf(ii = 1, 1, 2)) = w(IIf(ii = 1, 1, 2)) & _
                    IIf(w(IIf(ii = 1, 1, 2)) <> "", ",", "") & i
                    dic(s) = w
                End If
            Next
        Next
        ReDim b(1 To UBound(a, 1) * 2, 1 To UBound(a, 2)): n = 1
        For Each e In dic
            x(0) = Split(dic(e)(1), ",")
            x(1) = Split(dic(e)(2), ",")
            t = UBound(x(0))
            If t < UBound(x(1)) Then t = UBound(x(1))
            If UBound(x(0)) > -1 Then
                For i = 0 To UBound(x(0))
                    For ii = 1 To 4
                        b(n, ii) = a(x(0)(i), ii)
                    Next
                Next
            End If
            If UBound(x(1)) > -1 Then
                For i = 0 To UBound(x(1))
                    For ii = 6 To UBound(a, 2)
                        b(n + i, ii) = a(x(1)(i), ii)
                    Next
                Next
            End If
            n = n + t + 1
        Next
        With .[a2].Resize(n, UBound(b, 2))
            .NumberFormat = "@"
            .Value = b
            .Columns("a:d").Borders.Weight = 2
            .Columns("f:i").Borders.Weight = 2
            .EntireColumn.AutoFit
            .Parent.Select
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Hi Jindon.

I have tried your code first. On initial inspection, it seems to be doing what I tried to explain. I have attached a new file with updated data.

On the results tab, on line 7107, this should appear on the right hand side on line 2757 on the right hand side because even though B <> G, C does equal H. If you can have a look at this and see what it is doing it that would be much appreciated.

Regards

new example.xlsm

As it's a new requirement so in order to no waste time attach at least the exact expected result according to your last attachment …

Unclear : compare only 2 columns side by side or 3 ?!

According to the post #6 attachment a starter VBA demonstration using only columns C & D as keys :

PHP Code: 

Sub Demo1()
    Dim C%, V(1 To 2), W(1 To 2), L&(1 To 2), S$(), K%, R&
    For C = 1 To 2
    With Sheets(C).[A1].CurrentRegion.Resize(Sheets(C).[A1].CurrentRegion.Rows.Count + 1).Columns
        V(C) = .Value
        W(C) = .Parent.Evaluate(.Item(3).Address & "&"" ""&" & .Item(4).Address)
    End With
        L(C) = 2
    Next
        If UBound(V(1), 2) <> UBound(V(2), 2) Then Beep: Exit Sub
        ReDim S(1 To UBound(V(1)) + UBound(V(2)), 1 To 1 + UBound(V(1), 2) * 2)
        K = UBound(V(1), 2) + 1
        For C = 1 To UBound(V(1), 2):  S(1, C) = V(1)(1, C):  S(1, K + C) = V(2)(1, C):  Next
        R = 1
    With Application
    Do
        R = R + 1
     If W(1)(L(1), 1) = W(2)(L(2), 1) Then
        W(1)(L(1), 1) = Empty:  W(2)(L(2), 1) = Empty
        For C = 1 To UBound(V(1), 2):  S(R, C) = V(1)(L(1), C):  S(R, K + C) = V(2)(L(2), C):  Next
        L(1) = L(1) + 1
        L(2) = L(2) + 1
     ElseIf IsError(.Match(W(1)(L(1), 1), W(2), 0)) Then
        W(1)(L(1), 1) = Empty
        For C = 1 To UBound(V(1), 2):  S(R, C) = V(1)(L(1), C):  Next
        L(1) = L(1) + 1
     Else
        W(2)(L(2), 1) = Empty
        For C = 1 To UBound(V(2), 2):  S(R, K + C) = V(2)(L(2), C):  Next
        L(2) = L(2) + 1
     End If
    Loop While L(1) < UBound(V(1)) Or L(2) < UBound(V(2))
       .ScreenUpdating = False
        If Sheets.Count > 2 Then Sheets(3).UsedRange.Clear: .Goto Sheets(3).[A1], True Else Sheets.Add(, Sheets(2)).Name = "Mixed"
        With [A1].Resize(R, UBound(S, 2)):  .NumberFormat = " @ ":  .Value2 = S:  End With
        Range(Replace("B2:B#,D2:E#,H2:H#,J2:K#", "#", R)).Columns.AutoFit
       .ScreenUpdating = True
    End With
End Sub 


► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

@Marc L

Thanks very much. I'll try it over the weekend hopefully. your post says it uses columns C and D as keys, are you able to highlight in the code where it does this please?

Thanks

Originally Posted by BryanRobson

your post says it uses columns C and D as keys, are you able to highlight in the code where it does this please?

Yes 'cause impossible mission to produce your expected result as it is when comparing 3 columns
so the reason why comparing only 2 columns to get the same result …

I used arrays to compare data but the classic beginner formula way is fast enough, easier to understand and maintain if you prefer …

In my post #8 VBA demonstration columns are compared within the Do Loop section, W(1) versus W(2) …

Originally Posted by Marc L

According to the post #6 attachment a starter VBA demonstration using only columns C & D as keys :

PHP Code: 

Sub Demo1()
    Dim C%, V(1 To 2), W(1 To 2), L&(1 To 2), S$(), K%, R&
    For C = 1 To 2
    With Sheets(C).[A1].CurrentRegion.Resize(Sheets(C).[A1].CurrentRegion.Rows.Count + 1).Columns
        V(C) = .Value
        W(C) = .Parent.Evaluate(.Item(3).Address & "&"" ""&" & .Item(4).Address)
    End With
        L(C) = 2
    Next
        If UBound(V(1), 2) <> UBound(V(2), 2) Then Beep: Exit Sub
        ReDim S(1 To UBound(V(1)) + UBound(V(2)), 1 To 1 + UBound(V(1), 2) * 2)
        K = UBound(V(1), 2) + 1
        For C = 1 To UBound(V(1), 2):  S(1, C) = V(1)(1, C):  S(1, K + C) = V(2)(1, C):  Next
        R = 1
    With Application
    Do
        R = R + 1
     If W(1)(L(1), 1) = W(2)(L(2), 1) Then
        W(1)(L(1), 1) = Empty:  W(2)(L(2), 1) = Empty
        For C = 1 To UBound(V(1), 2):  S(R, C) = V(1)(L(1), C):  S(R, K + C) = V(2)(L(2), C):  Next
        L(1) = L(1) + 1
        L(2) = L(2) + 1
     ElseIf IsError(.Match(W(1)(L(1), 1), W(2), 0)) Then
        W(1)(L(1), 1) = Empty
        For C = 1 To UBound(V(1), 2):  S(R, C) = V(1)(L(1), C):  Next
        L(1) = L(1) + 1
     Else
        W(2)(L(2), 1) = Empty
        For C = 1 To UBound(V(2), 2):  S(R, K + C) = V(2)(L(2), C):  Next
        L(2) = L(2) + 1
     End If
    Loop While L(1) < UBound(V(1)) Or L(2) < UBound(V(2))
       .ScreenUpdating = False
        If Sheets.Count > 2 Then Sheets(3).UsedRange.Clear: .Goto Sheets(3).[A1], True Else Sheets.Add(, Sheets(2)).Name = "Mixed"
        With [A1].Resize(R, UBound(S, 2)):  .NumberFormat = " @ ":  .Value2 = S:  End With
        Range(Replace("B2:B#,D2:E#,H2:H#,J2:K#", "#", R)).Columns.AutoFit
       .ScreenUpdating = True
    End With
End Sub 


► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

Hi Marc L.

I just want to explore your code as its taking a while to process the data as the files are quite large. Just to re-iterate, in the attached file, I want to compare column D to column K and move down the data in column A to F or the data in column H to L so that the lines match up based on what is in column D and K. if there is a value in column D but no match in column K then the data from column H to L needs to be moved down so that the next sequence matches/lines up. Likewise, if there is a value in column K but no match in column D, then the data from column A to F needs to be moved down so that the next sequence matches/lines up. I don't want to lose any lines/deleted. plus there may be sometimes no number in columns D and K but I also want to keep those and not lose the lines

Regards

compare.xlsx

I have NOT checked any of your attachments.
On my machine with 2900+ rows of data in Column A and slightly under 600 rows of data in Column B it takes just over 2 seconds to run. So certainly not a "speedster"
All data rows are sonsecutive, without empty cells before starting.
It moves the data cells in Column B down to be on the same row as the data in Column A.
No error checking in this suggestion.
If you want to try it, change references where required.
It's an old one that I had still hanging around so not the most sophisticated.

Sub Move_To_Same_Value_Row()
Dim i As Long, ii As Long, lr As Long, msg1 As String
If Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(2).Count <> Cells(Rows.Count, 2).End(xlUp).Row Then MsgBox "Delete Empties First.": Exit Sub
lr = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    For i = 1 To lr
        If Cells(i, 2).Value <> Cells(i, 2).Offset(, -1).Value Then
            ii = Columns(1).Find(Cells(i, 2).Value, , , 1).Row
                Cells(i, 2).Resize(ii - i).Insert Shift:=xlDown
            i = ii
        End If
    Next i
    Range(Cells(Cells(Rows.Count, 1).End(xlUp).Offset(1).Row, 1), Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1)).EntireRow.Delete
Application.ScreenUpdating = True
End Sub

@jolivanes

Hi. Thanks for the reply. I'll try the code this weekend hopefully.

if your code compares column A to column B, I actually need it to compare columns A to F, B to G and C to H.

Originally Posted by jolivanes

I have NOT checked any of your attachments.
On my machine with 2900+ rows of data in Column A and slightly under 600 rows of data in Column B it takes just over 2 seconds to run. So certainly not a "speedster"
All data rows are sonsecutive, without empty cells before starting.
It moves the data cells in Column B down to be on the same row as the data in Column A.
No error checking in this suggestion.
If you want to try it, change references where required.
It's an old one that I had still hanging around so not the most sophisticated.

Sub Move_To_Same_Value_Row()
Dim i As Long, ii As Long, lr As Long, msg1 As String
If Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(2).Count <> Cells(Rows.Count, 2).End(xlUp).Row Then MsgBox "Delete Empties First.": Exit Sub
lr = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    For i = 1 To lr
        If Cells(i, 2).Value <> Cells(i, 2).Offset(, -1).Value Then
            ii = Columns(1).Find(Cells(i, 2).Value, , , 1).Row
                Cells(i, 2).Resize(ii - i).Insert Shift:=xlDown
            i = ii
        End If
    Next i
    Range(Cells(Cells(Rows.Count, 1).End(xlUp).Offset(1).Row, 1), Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1)).EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Hi jolivanes.

I just want to explore your code as its taking a while to process the data as the files are quite large. Just to re-iterate, in the attached file, I want to compare column D to column K and move down the data in column A to F or the data in column H to L so that the lines match up based on what is in column D and K. if there is a value in column D but no match in column K then the data from column H to L needs to be moved down so that the next sequence matches/lines up. Likewise, if there is a value in column K but no match in column D, then the data from column A to F needs to be moved down so that the next sequence matches/lines up. I don't want to lose any lines/deleted. plus there may be sometimes no number in columns D and K but I also want to keep those and not lose the lines


Regards

compare.xlsx

Re Post #12.
I am sure you can change a 1 (Column A) to a 2 (Column B) or a 3 (Column C) or a 4 or what ever number is required to represent the Columns.
If you are not sure, let us know.

Hi Jindon.

Thanks vey much. that has resolved that problem. I will continue to work with other live files to check results with me doing it the manual way.

Regards

Hi Jindon.

The input files format have recently changed. So an extra column has been inserted into todays file and yesterdays file. Column B and I. I want the data in those
columns to be retained but for the purpose of your code it will throw the columns out.

Can you please amend your code to cater for the new data in column B and I ?

Thanks very much.

Regards

example.xlsx

Hi Jindon.

Many thanks for your reply. Much appreciated. Please have a look at the attached file.

from line 7106 there are some oddities. there are 4 rows of random dates in column F. I am not sure what they are?
Also, there are 4 records from column H. 10020 has a matching record as 058498 has a record somewhere on the left hand side and right hand side. So they need to be matched up in the right place in the file.

1974, 7052, 7388 are only on the right hand side of the file, so there is no match for them but they just need to go in the file in the correct sequence with blanks on the left hand side as there is no match.

Regards

example.xlsx

Try change to

Sub test2()
    Dim a, b, e, x, w, s(1) As String, dic As Object
    Dim i As Long, ii As Long, iii As Long, iv, n As Long, t As Long
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("results")
        a = Intersect(.Columns("a:m"), .UsedRange)
        For i = 2 To UBound(a, 1)
            If a(i, 8) <> "" Then
                s(0) = "": s(1) = ""
                For ii = 9 To 12
                    If (ii <> 9) * (ii <> 10) Then s(0) = s(0) & Chr(2) & a(i, ii)
                    If (ii <> 9) * (ii <> 11) Then s(1) = s(1) & Chr(2) & a(i, ii)
                Next
                dic(s(0)) = dic(s(0)) & IIf(dic(s(0)) <> "", ",", "") & i
                dic(s(1)) = dic(s(1)) & IIf(dic(s(1)) <> "", ",", "") & i
            End If
        Next
        ReDim b(1 To UBound(a, 1) * 2, 1 To UBound(a, 2))
        For i = 2 To UBound(a, 1)
            If a(i, 1) <> "" Then
                s(0) = "": s(1) = "": n = n + 1
                For ii = 1 To 7
                    b(n, ii) = a(i, ii)
                    If (ii > 1) * (ii < 6) Then
                        If (ii <> 2) * (ii <> 3) Then s(0) = s(0) & Chr(2) & a(i, ii)
                        If (ii <> 2) * (ii <> 4) Then s(1) = s(1) & Chr(2) & a(i, ii)
                    End If
                Next
                For ii = 0 To 1
                    If dic.exists(s(ii)) Then
                        x = Split(dic(s(ii)), ",")
                        For iii = 0 To UBound(x)
                            t = 0
                            If a(x(iii), 8) <> "z" Then
                                For iv = 8 To UBound(a, 2)
                                    b(n + t, iv) = a(x(iii), iv)
                                Next
                                a(x(iii), 8) = "z": t = t + 1
                            End If
                        Next
                        If dic.exists(s(0)) Then dic.Remove s(0)
                        If dic.exists(s(1)) Then dic.Remove s(1)
                    End If
                Next
                n = n + t - 1
            End If
        Next
        If dic.Count Then
            For Each e In dic
                x = Split(dic(e), ",")
                For i = 0 To UBound(x)
                    If a(x(i), 8) <> "z" Then
                        n = n + 1
                        For ii = 8 To UBound(a, 2)
                            b(n, ii) = a(x(i), ii)
                        Next
                        a(x(i), 8) = "z"
                    End If
                Next
            Next
        End If
        With .[a2].Resize(n, UBound(b, 2))
            .Resize(UBound(a, 1)).ClearContents
            .NumberFormat = "@"
            .Value = b
            .Columns("a:f").Borders.Weight = 2
            .Columns("g:m").Borders.Weight = 2
            .EntireColumn.AutoFit
            .Parent.Select
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Hi Jindon.

Many thanks for your reply and amended code.

10020 is now resolved and 7388. 7052 has 4 on the left and 3 only on the right. there is one missing on the right hand side. 1974 is missing. 1974 should be ion the right hand side with blank cells on the left hand side.

You are nearly there I would say.

Regards

@BryanRobson

Administrative Note re. Forum Guideline #2:

Please don't quote whole posts, especially when you are responding to the one immediately preceding your own - it's just clutter and rarely necessary.

If you are responding out of sequence, it is usually enough just to mention the helper's user name (e.g @AliGW).

If you do need to quote, limit the quoted section just to the section to which you wish to draw your helper's attention or a direct question to which you wish to respond.

For normal conversational replies, try using the QUICK REPLY box below or the REPLY button instead of REPLY WITH QUOTE.

Ok great. I'm just going out for the day
so I'll have a look later.

Have a good day

Hi Jindon.

I have just checked and 7052 / 059978 is on the right and the left

Regards

Originally Posted by jindon

Line up the row where D=K

Sub test3()
    Dim a, i As Long, ii As Long, iii As Long, w
    Application.ScreenUpdating = False
    With Sheets("results")
        .AutoFilterMode = False
        .UsedRange.Offset(1).Resize(, 13).ClearContents
        Sheets("today").[a1].CurrentRegion.Resize(, 6).Copy .[a1]
        Sheets("yesterday").[a1].CurrentRegion.Resize(, 6).Copy .[h1]
        a = Intersect(.Columns("a:m"), .UsedRange)
        With CreateObject("Scripting.Dictionary")
            For ii = 1 To UBound(a, 2) Step 7
                For i = 2 To UBound(a, 1)
                    If a(i, ii + 3) <> "" Then
                        If Not .exists(a(i, ii + 3)) Then
                            ReDim w(1 To UBound(a, 2))
                        Else
                            w = .Item(a(i, ii + 3))
                        End If
                        For iii = 1 To 6
                            w(iii + IIf(ii = 1, 0, 7)) = a(i, iii + IIf(ii = 1, 0, 7))
                        Next
                        .Item(a(i, ii + 3)) = w
                    End If
                Next
            Next
            a = Application.Index(.items, 0, 0)
        End With
        With .[a2].Resize(UBound(a, 1), UBound(a, 2))
            .CurrentRegion.Offset(1).ClearContents
            .NumberFormat = "@"
            .Value = a
            .Columns("a:f").Borders.Weight = 2
            .Columns("g:m").Borders.Weight = 2
            .EntireColumn.AutoFit
            .Parent.Select
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Hi jindon

I just want to explore your code as its taking a while to process the data as the files are quite large. Just to re-iterate, in the attached file, I want to compare column D to column K and move down the data in column A to F or the data in column H to L so that the lines match up based on what is in column D and K. if there is a value in column D but no match in column K then the data from column H to L needs to be moved down so that the next sequence matches/lines up. Likewise, if there is a value in column K but no match in column D, then the data from column A to F needs to be moved down so that the next sequence matches/lines up. I don't want to lose any lines/deleted. plus there may be sometimes no number in columns D and K but I also want to keep those and not lose the lines


Regards

compare.xlsx