VBA compare 2 columns against 2 columns and move data to sheet2

I

Invader126

New Member
Joined
Dec 30, 2014
Messages
2
hi,

new to this site. dont have a lot of experience with VBA.

i need a vba code to do the following
Values in column A and C, Digits in column B and D
the Macro needs to compare the data of column A and B against column C and D and cut / move the duplicate data to Sheet2. it needs to be in the exact same format as sheet 1. value, digits, value, digits.
at the end i should be left with all entries in columns A:D of entries that did not match and in sheet 2 all the entries that did match. it should only match one entry in the columns. if there are two matches in the first line and only one in the second, then only one should be moved.

<code>example:
Sheet 1 before start
Column A Column B Column C Column D
20 10 10 20
10 7 17 10
10 20 8 7
10 7 10 7
then afterwards:
Sheet 1:
Column A Column B Column C Column D
20 10 17 10
10 7 8 7
Sheet 2:
Column A Column B Column C Column D
10 7 10 20
10 20 10 7

</code>any help would be appreciated.
thank you
 
Last edited:

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
Hello,

does this work as expected (i get the same results as per you example).

Code: 
Sub MATCHING()
    Application.ScreenUpdating = False
    For MY_ROWS = 1 To Range("A" & Rows.Count).End(xlUp).Row
        MY_TEXT = Range("A" & MY_ROWS).Value & Range("B" & MY_ROWS).Value
        For MY_NEW_ROWS = 1 To Range("C" & Rows.Count).End(xlUp).Row
            MY_TEXT_2 = Range("C" & MY_NEW_ROWS).Value & Range("D" & MY_NEW_ROWS).Value
            If MY_TEXT = MY_TEXT_2 Then
                Range("A" & MY_ROWS & ":B" & MY_ROWS).Copy
                Sheets("Sheet2").Range("A" & MY_ROWS).PasteSpecial (xlPasteAll)
                Range("A" & MY_ROWS & ":B" & MY_ROWS).ClearContents
                Range("C" & MY_NEW_ROWS & ":D" & MY_NEW_ROWS).Copy
                Sheets("Sheet2").Range("C" & MY_NEW_ROWS).PasteSpecial (xlPasteAll)
                Range("C" & MY_NEW_ROWS & ":D" & MY_NEW_ROWS).ClearContents
            End If
        Next MY_NEW_ROWS
    Next MY_ROWS
    For MY_SHEETS = 1 To 2
        With Sheets(MY_SHEETS)
            .Columns("A:D").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        End With
    Next MY_SHEETS
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
onlyadrafter said:
Hello,

does this work as expected (i get the same results as per you example).

Code: 
Sub MATCHING()
    Application.ScreenUpdating = False
    For MY_ROWS = 1 To Range("A" & Rows.Count).End(xlUp).Row
        MY_TEXT = Range("A" & MY_ROWS).Value & Range("B" & MY_ROWS).Value
        For MY_NEW_ROWS = 1 To Range("C" & Rows.Count).End(xlUp).Row
            MY_TEXT_2 = Range("C" & MY_NEW_ROWS).Value & Range("D" & MY_NEW_ROWS).Value
            If MY_TEXT = MY_TEXT_2 Then
                Range("A" & MY_ROWS & ":B" & MY_ROWS).Copy
                Sheets("Sheet2").Range("A" & MY_ROWS).PasteSpecial (xlPasteAll)
                Range("A" & MY_ROWS & ":B" & MY_ROWS).ClearContents
                Range("C" & MY_NEW_ROWS & ":D" & MY_NEW_ROWS).Copy
                Sheets("Sheet2").Range("C" & MY_NEW_ROWS).PasteSpecial (xlPasteAll)
                Range("C" & MY_NEW_ROWS & ":D" & MY_NEW_ROWS).ClearContents
            End If
        Next MY_NEW_ROWS
    Next MY_ROWS
    For MY_SHEETS = 1 To 2
        With Sheets(MY_SHEETS)
            .Columns("A:D").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        End With
    Next MY_SHEETS
    Application.ScreenUpdating = True
End Sub
Click to expand...

hi,

thanks for the quick reply, it almost does what i want. the only problem i have is that it moves an extra line. will try to explain:

it is moving value that does not have matches as well and removing values without moving it to sheet 2. below is another list of numbers that i quickly ran to check. the left ones only has 2 12 once, and the right one has it twice. it only has to move the one 2 12 on the right to sheet 2 as it only appears once on the left. also it does not move the one on the left to sheet 2 but it does delete it from sheet 1. hope it makes sense.

i have the below code from another place that almost does exactly what i want. it does everything, but it only checks columns a vs b, and i need one that checks columns a and b vs c and d. also it needs to move both columns. hopefully with the code it will make more sense since it doesnt make much sense to me...

thanks you much appreciated

Code: 
Sub MATCHING()    Dim wsMain As Worksheet, wsOutput As Worksheet
    Dim lRowColA As Long, lRowColB As Long, i As Long, j As Long
    Dim Acell As Range, ColARng As Range, ColBRng As Range
    '~~> Set input Sheet and output sheet
    Set wsMain = ThisWorkbook.Sheets("Balancing")
    Set wsOutput = ThisWorkbook.Sheets("Remove")
    '~~> Start Row in output sheet
    j = 1
    With wsMain
        '~~> Get last row in Col A & B
        lRowColA = .Range("A" & .Rows.Count).End(xlUp).Row
        lRowColB = .Range("B" & .Rows.Count).End(xlUp).Row
        '~~> Set your actual data range in Col A and B
        Set ColARng = .Range("A1:A" & lRowColA)
        Set ColBRng = .Range("B1:B" & lRowColB)
        '~~> Loop through Col A
        For i = 1 To lRowColA
            If Len(Trim(.Range("A" & i).Value)) <> 0 Then
                '~~> Check if there are duplicates of Col A value in Col B
                If Application.WorksheetFunction.CountIf(ColBRng, _
                .Range("A" & i).Value) > 0 Then
                
                    '~~> If found write to output sheet
                    wsOutput.Cells(j, 1).Value = .Range("A" & i).Value
                    wsOutput.Cells(j, 3).Value = .Range("A" & i).Value
                    '~~> Find the duplicate value in Col B
                    Set Acell = ColBRng.Find(What:=.Range("A" & i).Value, _
                    LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
                    '~~> Clear the duplicate value in Col B
                    Acell.ClearContents
                    '~~> Clear the duplicate value in Col A
                    .Range("A" & i).ClearContents
                    '~~> Set i = 1 to restart loop and increment
                    '~~> the next row for output sheet
                    i = 1: j = j + 1
                End If
            End If
        Next i
    End With
End Sub





[TABLE="width: 192"]


 <colgroup><col style="width: 48pt;" span="4" width="64">
 <tbody>[TR]

  [TD="width: 64, bgcolor: transparent, align: right"][FONT=Calibri]4[/FONT][/TD]

  [TD="width: 64, bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]14[/COLOR][/SIZE][/FONT][/TD]

  [TD="width: 64, bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]4[/COLOR][/SIZE][/FONT][/TD]

  [TD="width: 64, bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]23[/COLOR][/SIZE][/FONT][/TD]

 [/TR]

 [TR]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri]5[/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]15[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]5[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]24[/COLOR][/SIZE][/FONT][/TD]

 [/TR]

 [TR]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri]6[/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]16[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]6[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]25[/COLOR][/SIZE][/FONT][/TD]

 [/TR]

 [TR]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri]7[/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]26[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]10[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]29[/COLOR][/SIZE][/FONT][/TD]

 [/TR]

 [TR]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri]9[/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]19[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]1[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]30[/COLOR][/SIZE][/FONT][/TD]

 [/TR]

 [TR]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri]10[/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]20[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]2[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]12[/COLOR][/SIZE][/FONT][/TD]

 [/TR]

 [TR]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri]7[/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]26[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]7[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]26[/COLOR][/SIZE][/FONT][/TD]

 [/TR]

 [TR]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri]3[/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]31[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]8[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]27[/COLOR][/SIZE][/FONT][/TD]

 [/TR]

 [TR]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri]8[/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]27[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]2[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]12[/COLOR][/SIZE][/FONT][/TD]

 [/TR]

 [TR]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri]2[/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]12[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]3[/COLOR][/SIZE][/FONT][/TD]

  [TD="bgcolor: transparent, align: right"][FONT=Calibri][SIZE=3][COLOR=#000000]31[/COLOR][/SIZE][/FONT][/TD]



 









[/TR]


</tbody>[/TABLE]
 
Upvote 0
Hello,

found a bit of a workround. Does this work as expected?

Code: 
Sub MATCHING()
    Application.ScreenUpdating = False
    For MY_ROWS = 1 To Range("A" & Rows.Count).End(xlUp).Row
        MY_TEXT = Range("A" & MY_ROWS).Value & Range("B" & MY_ROWS).Value
        For MY_NEW_ROWS = 1 To Range("C" & Rows.Count).End(xlUp).Row
            MY_TEXT_2 = Range("C" & MY_NEW_ROWS).Value & Range("D" & MY_NEW_ROWS).Value
            If MY_TEXT = MY_TEXT_2 Then
                MY_FOUND_A = MY_FOUND_A + 1
                If MY_FOUND_A = 1 Then
                    Range("A" & MY_ROWS & ":B" & MY_ROWS).Copy
                    Sheets("Sheet2").Range("A" & MY_ROWS).PasteSpecial (xlPasteAll)
                    Range("A" & MY_ROWS & ":B" & MY_ROWS).ClearContents
                End If
                If MY_FOUND_A = 1 Then
                    Range("C" & MY_NEW_ROWS & ":D" & MY_NEW_ROWS).Copy
                    Sheets("Sheet2").Range("C" & MY_NEW_ROWS).PasteSpecial (xlPasteAll)
                    Range("C" & MY_NEW_ROWS & ":D" & MY_NEW_ROWS).ClearContents
                Else
                    Range("C" & MY_NEW_ROWS & ":D" & MY_NEW_ROWS).ClearContents
                End If
                
            End If
        Next MY_NEW_ROWS
        MY_FOUND_A = 0
    Next MY_ROWS
    For MY_SHEETS = 1 To 2
        With Sheets(MY_SHEETS)
            .Columns("A:D").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        End With
    Next MY_SHEETS
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
Complex Move data from two spreadsheets with similar data in different columns to a specific column in an existing spreadsheet(Sheet 3)
Replies
0
Views
164
JMC57
J
C
  • Question
How to get my macro to stop at the last recognized line
Replies
6
Views
301
Coco1
C
B
  • Question
Getting error if linked cell row deleted in different sheet of large data.
Replies
3
Views
146
Peter_SSs
Peter_SSs
excelbytes
  • Solved
SUMIFS With Multiple Criteria In One Column
2 3
Replies
26
Views
2K
KRice
K
S
  • Question
Unexpected and inconsistent error with ranking rows based on criteria
Replies
2
Views
162
strugglingaccountant
S

Forum statistics

Threads
1,216,107
Messages
6,128,869
Members
449,475
Latest member
Parik11

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