1

Follow up question from this previous post:

VBA - Compare Column on Previous Report With New Report to Find New Entries

The solution below compares a report generated last week with a report generated this week and it finds the differences between the two, in column A. Then it copies the differences from column A to a new sheet into column A. However, the scope has changed slightly in that I need to copy from the original sheet the difference in column A and the adjacent cell in column B.

For example:

Column A contains User ID's and Column B contains Employee Names

The comparison is done on the User ID, and when a difference is found, that specific User ID is copied to the new sheet. However, I need the User ID as well as the Employee Name copied to the new sheet, not just the User ID.

I cannot copy the entire row because there is other information in the other columns that are not necessary for the report summary.

Here is the code provided by Vityata:

    Public Sub FindDifferences()

        Dim firstRange As Range
        Dim secondRange As Range

        Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
        Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
        Dim wks3 As Worksheet: Set wks3 = Worksheets(3)

        Set firstRange = wks1.UsedRange
        Set secondRange = wks2.UsedRange

        Dim myCell  As Range

        For Each myCell In firstRange
            If myCell <> secondRange.Range(myCell.Address) Then
                wks3.Range(myCell.Address) = myCell
            End If
        Next myCell

    End Sub

Here is the current code I have:

Public Sub FindDifferences()

    Dim firstRange As Range
    Dim secondRange As Range
    Dim myCell As Range

    Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet

    'Find Removed Wintel Servers
    Set wks1 = ActiveWorkbook.Sheets("sh1")
    Set wks2 = ActiveWorkbook.Sheets("sh2")
    Set wks3 = ActiveWorkbook.Sheets("sh3")

    Set firstRange = Range(wks1.Range("A1"), wks1.Range("A" & Rows.Count).End(xlUp))
    Set secondRange = Range(wks2.Range("A1"), wks2.Range("A" & Rows.Count).End(xlUp))

    For Each myCell In secondRange
        If WorksheetFunction.CountIf(firstRange, myCell) = 0 Then

            myCell.Copy
            wks3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            wks3.Cells(Rows.Count, 1).End(xlUp).PasteSpecial xlPasteFormats

        End If
    Next myCell

wks3.Range("A1").Select

End Sub
Eitel Dagnin
  • 959
  • 4
  • 24
  • 61
  • 1
    Try adding `wks3.Range(myCell.Address).Offset(0,1).Value = myCell.Offset(0,1).Value` underneath the `wks3.Range(myCell.Address) = myCell` line – jamheadart May 17 '18 at 08:46
  • @jamheadart Really sorry, I forgot that I modified the code since I got the solution from Vityata.. The line you're referring to is no longer apart of the code. Would you mind reviewing it perhaps please? – Eitel Dagnin May 17 '18 at 09:00

2 Answers2

1

This is probably not the easiest way to do it, but it works for me. Let me know if you need me to explain the different variables.
The code presumes you have headers in the first row on every sheet.

Sub FindDifferences()

    Dim LastRow As Integer
    Dim LastRow2 As Integer
    Dim rng As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rng4 As Range
    Dim Counter As Integer
    Dim Counter2 As Integer


    Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
    Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
    Dim wks3 As Worksheet: Set wks3 = Worksheets(3)

        LastRow = wks1.Cells(Rows.Count, "A").End(xlUp).Row
        LastRow2 = wks2.Cells(Rows.Count, "A").End(xlUp).Row
        Set rng = wks1.Range("A2")
        Set rng2 = wks1.Range("A2:B2")
        Set rng3 = wks2.Range("A2:A" & LastRow2)
        Set rng4 = wks3.Range("A2:B2")
        Counter = 2
        Counter2 = 2

    For x = 1 To LastRow

        Set ValueCheck = rng3.Find(rng.Value, LookIn:=xlValues)

        If ValueCheck Is Nothing Then
        rng2.Copy _
        Destination:=rng4
        Counter2 = Counter2 + 1
        End If

        Counter = Counter + 1
        Set rng = wks1.Range("A" & Counter)
        Set rng2 = wks1.Range("A" & Counter & ":B" & Counter)
        Set rng4 = wks3.Range("A" & Counter2 & ":B" & Counter2)

    Next x

End Sub
DirtyDeffy
  • 497
  • 7
  • 18
  • Thank you very much, this works great.. The only issue is that it overwrites the headers in the sheet it is copied to.. – Eitel Dagnin May 17 '18 at 10:07
  • You're welcome. Don't worry this should be easy to correct. Are the headers located on the first row? – DirtyDeffy May 17 '18 at 10:25
  • I've updated my answer - try it now. Are there headers on the first row in sheet 1 and 2 aswell? – DirtyDeffy May 17 '18 at 11:04
  • Sorry to do this, but I just used my old code and ran the macro then I used your code and ran the macro and your code is copying data but its not the differences. Im trying to figure out which data its actually copying – Eitel Dagnin May 17 '18 at 13:35
  • It copies the differences when i use it. But i think i might have misunderstood a crucial part. When making the comparison, should it look for the value in the entire column or just the same cell on the other list? The code I've written compares cell A1 on sheet 1 with cell A1 on sheet 2. Then it compares cell A2 on sheet 1 with cell A2 on sheet 2 and so on. It does not look for the value in the entire column. – DirtyDeffy May 17 '18 at 13:49
  • Oooh yes, you misunderstood that.. Im sorry.. The whole thing is that these sheets contain the data of users that were removed from our systems in the last week.. So I need to do a comparison between the 2 sheets to see which users have been removed.. So my original code did just that, but I couldn't figure out how to copy the adjacent cell with it.. – Eitel Dagnin May 17 '18 at 14:13
  • Okay I see - I will work on a solution when I get the time and post it here. I'm sure Vityata has a neat solution for it though ;) – DirtyDeffy May 17 '18 at 14:27
  • @EitelDagnin I have edited the code. It should work as intended now :) Notice that the code presumes you have headers in the first row on every sheet – DirtyDeffy May 18 '18 at 07:11
  • Thank you sooooo much! It really is working 100% now :) – Eitel Dagnin May 18 '18 at 08:46
  • @EitelDagnin Great! - Happy to help :) – DirtyDeffy May 18 '18 at 09:34
0

In your current code you can replace your line

        myCell.Copy

With this:

.Range(myCell.Address & ":" & myCell.Offset(0,1).Address).Copy

I believe this would work ok, I haven't tested properly, if you get an error let me know I'll trial it

jamheadart
  • 5,047
  • 4
  • 32
  • 63
  • Thank your your reply, unfortunately this only copies the headers from the sheets and replaces the headers in the sheet it is copied to.. – Eitel Dagnin May 17 '18 at 10:06