Need help comparing two large spreadsheets and changing values

[techn1um]

Hi, I am after abit of help which is above and beyond my excel skills.

I have two spreadsheets lets say called "SheetA" and "SheetB"

Sheet A needs to match the "username" in column B to the username in column B on the other sheet (Sheet B).

If the usernames match then I need it to copy the data in that line in column D to column D on the other spreadsheet on the same username.

If a field has no match, then do nothing and carry onto the next line.

Is anyone able to help, ive been scratching my head for ages and as its over 5000 lines then would take awhile to do side by side.

Thanks in advance.

T.

 

[mumps]

Try:

Sub CompareLists()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object
    Dim rngA As Range
    Set rngA = Sheets("SheetA").Range("B2", Sheets("SheetA").Range("B" & Rows.Count).End(xlUp))
    Dim rngB As Range
    Set rngB = Sheets("SheetB").Range("B2", Sheets("SheetB").Range("B" & Rows.Count).End(xlUp))
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In rngB
        If Not RngList.Exists(Rng.Value) Then
          RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each Rng In rngA
        If RngList.Exists(Rng.Value) Then
          Sheets("SheetA").Cells(Rng.Row, 4) = Sheets("SheetB").Cells(Sheets("SheetB").Range("B:B").Find(Rng).Row, 4)
        End If
    Next
    RngList.RemoveAll
    Application.ScreenUpdating = True
End Sub

 

[techn1um]

Thanks, I tried running it and get a debug error, heres the debug code -

Sub CompareLists()
Application.ScreenUpdating = False
Dim Rng As Range, RngList As Object
Dim rngA As Range
Set rngA = Sheets("DWFRS").Range("B2", Sheets("DWFRS").Range("B" & Rows.Count).End(xlUp))
Dim rngB As Range
Set rngB = Sheets("Colin").Range("B2", Sheets("Colin").Range("B" & Rows.Count).End(xlUp))
Set RngList = CreateObject("Scripting.Dictionary")
For Each Rng In rngB
If Not RngList.Exists(Rng.Value) Then
RngList.Add Rng.Value, Nothing
End If
Next
For Each Rng In rngA
If RngList.Exists(Rng.Value) Then
Sheets("DWFRS").Cells(Rng.Row, 4) = Sheets("Colin").Cells(Sheets("Colin").Range("B:B").Find(Rng).Row, 4)
End If
Next
RngList.RemoveAll
Application.ScreenUpdating = True
End Sub

and this was the highlighted line

Set rngA = Sheets("DWFRS").Range("B2", Sheets("DWFRS").Range("B" & Rows.Count).End(xlUp))

Just so you know I changed the names of the worksheets in your code, worksheet "DWFRS" column B has the list of user names and worksheet "Colin" column B also has the list of usernames to compare and then I need any matches to get the text from column D of DWFRS to then populate column D in spreadsheet "colin".

Hopefully im explaining myself, thanks for your help so far.

T.

 

[mumps]

I think the sheets may have gotten reversed. Tyr:

Sub CompareLists()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object
    Dim rngA As Range
    Set rngA = Sheets("Colin").Range("B2", Sheets("Colin").Range("B" & Rows.Count).End(xlUp))
    Dim rngB As Range
    Set rngB = Sheets("DWFRS").Range("B2", Sheets("DWFRS").Range("B" & Rows.Count).End(xlUp))
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In rngA
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each Rng In rngB
        If RngList.Exists(Rng.Value) Then
            Sheets("Colin").Cells(Rng.Row, 4) = Sheets("DWFRS").Cells(Sheets("Colin").Range("B:B").Find(Rng).Row, 4)
        End If
    Next
    RngList.RemoveAll
    Application.ScreenUpdating = True
End Sub

Also, when you are posting code, please use code tags. You can do this by highlighting the code once pasted and then clicking the # symbol in the top menu.

 

[techn1um]

Sorry about the posting code.

Still getting the same error "Runtime error 9 subscript out of range" and again the same line highlighted just the sheet names are different as per your latest code.

thanks again

Colin

 

[mumps]

It is always easier to help and test possible solutions if we could work with your actual file. Perhaps you could upload a copy of your file to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[techn1um]

Thanks, ive edited the files slightly as they contained sensitive data but think this should give you an idea.

https://www.dropbox.com/s/rtyahilxn4xqza2/DWFRS.xlsx?dl=0

https://www.dropbox.com/s/vi5ki6r8qne16g6/colin.xlsx?dl=0

hopefully that works.

thanks

Colin

 

[mumps]

My apologies but I didn't understand your original post correctly where you said you had two spreadsheets. You actually have two workbooks. Place the macro below in your Colin workbook and save it as a macro-enabled file. Make sure both workbooks are open and then run the macro.

Sub CompareLists()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Dim srcWS As Worksheet
    Set srcWS = Workbooks("DWFRS.xlsx").Sheets("Sheet1")
    Dim Rng As Range, RngList As Object
    Dim rngA As Range
    Set rngA = desWS.Range("B2", desWS.Range("B" & Rows.Count).End(xlUp))
    Dim rngB As Range
    Set rngB = srcWS.Range("B2", srcWS.Range("B" & Rows.Count).End(xlUp))
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In rngB
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each Rng In rngA
        If RngList.Exists(Rng.Value) Then
            desWS.Cells(Rng.Row, 4) = srcWS.Cells(srcWS.Range("B:B").Find(Rng).Row, 4)
        End If
    Next
    RngList.RemoveAll
    Application.ScreenUpdating = True
End Sub

 

[techn1um]

Thats brilliant, many many thanks for your help. I need to check the data but believe its exactly whats needed.

thanks again

Colin

 

[mumps]

You are very welcome.