VBA code for reconciliation

Anthony86

Board Regular
Joined
Jan 31, 2018
Messages
62
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I've done some searching and found a code that works reasonable well for what I need, but I do need a little help to edit it. The below code looks in two different tabs within the same spreadsheet and finds and discrepancies, then copies the rows over to a 3rd tab, pasting them 1 under the other. What I would like it to do is, have them side by side, and also highlight the cells in the first two tabs.

This is the code.

Code:
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet
    Dim lr1 As Long, lr2 As Long, rng1 As Range, rng2 As Range, c As Range
    Set sh1 = Worksheets("Tab1")
    Set sh2 = Worksheets("Tab2")
    Set sh3 = Worksheets("Tab3")
    lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'Get the last row with data for both list sheets
    lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
                'Establish the ranges on both sheets
    Set rng1 = sh1.Range("B2:C" & lr1)
    Set rng2 = sh2.Range("B2:C" & lr2)
    With sh3 'If header not there, put them in
        If .Range("A1") = "" Then
            .Range("A1") = "Header"
            .Range("B1") = "Header"
            .Range("C1") = "Header"
            .Range("D1") = "Header"
            .Range("E1") = "Header"
        End If
    End With
   For Each c In rng1 'Run a loop for each list ID mismatches and paste to sheet 3.
        If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
            'sh3.Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
            sh1.Rows(c.Row).Copy sh3.Cells(sh3.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
            sh2.Rows(c.Row).Copy sh3.Cells(sh3.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
        End If
    Next
End Sub

Any help will be greatly appreciated.
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Seems like this should work (untested)….
Code:
Dim RowTemp As Integer
For Each c In rng1
If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
c.DisplayFormat.Interior.ColorIndex = 3 'red
RowTemp = sh3.Cells(Rows.Count, 1).End(xlUp).Row + 1
sh1.Rows(c.Row).Copy sh3.Cells(RowTemp, 1)
sh2.Rows(c.Row).Copy sh3.Cells(RowTemp, 2)
End If
Next c
HTH. Dave
 
Upvote 0
Thanks for the response, and sorry for the slow reply. I just tested this code and it works fine on the first copy, but on the 2nd it fails.
Code:
sh2.Rows(c.Row).Copy sh3.Cells(RowTemp, 2)

Something about the copy area, and paste area being different sizes
 
Last edited:
Upvote 0
Not exactly sure where U want stuff... rows side by side?
Code:
Dim RowTemp As Integer, LastCol As Integer
For Each c In rng1
If WorksheetFunction.CountIf(Rng2, c.Value) = 0 Then
c.Interior.ColorIndex = 3 'red
RowTemp = sh3.Cells(Rows.Count, 1).End(xlUp).Row + 1
sh1.Rows(c.Row).Copy sh3.Cells(RowTemp, 1)
With Sheets("sh3")
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
sh2.Rows(c.Row).Copy sh3.Cells(RowTemp, LastCol)
End If
Next c
See what happens. Dave
 
Upvote 0
Hi Dave,

Yes I want the stuff side by side. I have 5 columns in my first two tabs(A-E), when the data doesn't match then I need it to copy both data sets and place in a 3rd tab from A-E, then G-K.(side by side).

I just tried the code above and I still get the same error message regarding copy/paste area.

Regards,
 
Upvote 0
Yes because I screwed that up. Trial this...
Code:
Dim RowTemp As Integer, LastCol As Integer
For Each c In rng1
If WorksheetFunction.CountIf(Rng2, c.Value) = 0 Then
c.Interior.ColorIndex = 3 'red
RowTemp = sh3.Cells(Rows.Count, 1).End(xlUp).Row + 1
sh1.Rows(c.Row).Copy sh3.Cells(RowTemp, 1)
With Sheets("sh3")
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
sh2.Rows(c.Row).Copy sh3.Cells(RowTemp, LastCol + 1)
End If
Next
Dave
 
Upvote 0
Hi Dave,

Still the same error message.

Run Time Error '1004'
You can't paste this here because the copy area and paste area aren't the same size.

Selecting just one cell in the paste area or an area that's the same size, and try pasting again.
 
Upvote 0
Yes I guess U would get that error when your trying to paste a whole row on top of another row. I really should have looked at this more carefully... my apologies. After some limited testing this seems to work. Dave
Code:
Option Explicit
Sub test()
Dim RowTemp As Integer, LastCol As Integer, Lr1 As Integer, Lr2 As Integer
Dim C As Range, Rng1 As Range, Rng2 As Range, NewRng As Range, NewRng2 As Range

With Sheets("Sh1")
Lr1 = .Range("B" & .Rows.Count).End(xlUp).Row
End With
With Sheets("Sh2")
Lr2 = .Range("B" & .Rows.Count).End(xlUp).Row
End With

Set Rng1 = Sheets("sh1").Range("B2:C" & Lr1)
Set Rng2 = Sheets("sh2").Range("B2:C" & Lr2)
Rng1.Interior.Color = xlNone

For Each C In Rng1
If WorksheetFunction.CountIf(Rng2, C.Value) = 0 Then
C.Interior.ColorIndex = 3 'red
RowTemp = Sheets("sh3").Cells(Sheets("sh3").Rows.Count, 1).End(xlUp).Row + 1
Set NewRng = Sheets("sh1").Range("A" & C.Row & ":E" & C.Row)
NewRng.Copy Sheets("sh3").Range("A" & RowTemp)
Application.CutCopyMode = False

With Sheets("sh3")
LastCol = .Cells(RowTemp, .Columns.Count).End(xlToLeft).Column
End With
Set NewRng2 = Sheets("sh2").Range("A" & C.Row & ":E" & C.Row)
NewRng2.Copy Sheets("sh3").Cells(RowTemp, LastCol + 2)
Application.CutCopyMode = False
End If
Next C
End Sub
 
Upvote 0
Hi Dave, Just tested this and it works a charm! Thanks for all your help very much appreciated.
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,148
Members
448,552
Latest member
WORKINGWITHNOLEADER

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