VBA Loop Move specific data from one sheet to another

[lfcreds11]

Hi all,

I am trying to write a script to lookup and copy specific info from one worksheet to another if certain criteria matches.

Worksheet A is called "Absent" and has 8 columns with A1 called CM

CM ID Number Date Shift Position Reason Hours PTO Hours


Worksheet B is called "Data" and has 8 columns with A1 called Date

Date CM Position Status Termination Reason Absent Reason Hours PTO Hours

I would like to do the following:

1- have the script look for matching names and dates
2-If both match, copy from the "Absent" worksheet data in column F (reason), column G (Hours) and column H (PTO hours) to the matching rows in worksheet "Data"
3-each time the script is run to refresh any new information

Notes:

Worksheet Data currently has 29,459 rows of data
Worksheet Absent currently has 1,781 rows of data


Thank you all!

 

[JLGWhiz]

See if this will work for you. The code should be run from the standard module1.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, fn As Range, c As Range, adr As String
Set sh1 = Sheets("Absent")
Set sh2 = Sheets("Data")
    With sh1
        For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
            Set fn = sh2.Range("B:B").Find(c.Value, , xlValues, xlWhole)
                If Not c Is Nothing Then
                    adr = fn.Address
                    Do
                        If c.Offset(, 2).Value = fn.Offset(, -1).Value Then
                            fn.Offset(, 4).Resize(, 3).Copy c.Offset(, 5)
                            Exit Do
                        End If
                        Set fn = sh2.Range("B:B").FindNext(fn)
                    Loop While adr <> fn.Address
                End If
        Next
    End With
End Sub

 

[lfcreds11]

Thank you for your quick reply. I ran into one error

adr = fn.Address

I receive the run-time error '91'
Object variable or With block variable not set

 

[JLGWhiz]

Had a typo in there. This should run better.

Sub t2()
Dim sh1 As Worksheet, sh2 As Worksheet, fn As Range, c As Range, adr As String
Set sh1 = Sheets("Absent")
Set sh2 = Sheets("Data")
    With sh1
        For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
            Set fn = sh2.Range("B:B").Find(c.Value, , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    adr = fn.Address
                    Do
                        If c.Offset(, 2).Value = fn.Offset(, -1).Value Then
                            fn.Offset(, 4).Resize(, 3).Copy c.Offset(, 5)
                            Exit Do
                        End If
                        Set fn = sh2.Range("B:B").FindNext(fn)
                    Loop While adr <> fn.Address
                End If
        Next
    End With
End Sub