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

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
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

R
  • Solved
VBA moving rows
2
Replies
14
Views
869
Joe4
Joe4
M
  • Question Question
Comparing (comma seperated) string values between two columns
2
Replies
14
Views
381
FormR
FormR
M
  • Question Question
Conditional Formatting/Moving Rows Based on Matching and Opposite Data
Replies
1
Views
204
Madam_Xavier
M
L
  • Question Question
Macro to correct entries across multiple sheets
Replies
1
Views
108
Lux Aeterna
L
G
  • Solved
If Else Loop macro running slow, anyway to speed it up?
Replies
9
Views
258
Alex Blakenburg
A

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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