VBA Loop through open workbooks and copy / paste match

[BenGee]

Hi

What I'm trying to do is loop through each open workbook and check if the value of D4 is similar to a value within range "A2:A17" within my workbook "AHT", the worksheet also called "AHT".

If true, then to copy the value of "I9" from the matching workbook and paste the value in my AHT workbook, column E (same row as the match).

My example,
- In workbook "AHT", Cell A5 has "Firstname Surname" (within range "A2:A17"),
- So loop through each open workbook and check if D4 within each workbook also has "Firstname Surname"
- If it does, then to copy the value of cell I9 from this matching workbook, and, paste the value in E5 within workbook "AHT".
- The contents of D4 in each workbook to loop through, will be like "1234 - Firstname Surname" so it can't be looking for an exact match.

The code I've tried so far is below, but I get run-time error 9, subscript out of range.

For Each WB In Workbooks
    If WB.Name <> "AHT" And WB.Name <> "0005*" Then
        With WB.Sheets(1)
            If Range("D4") Like Workbooks("AHT").Worksheets("AHT").Range("A2:A17") Then
                .Range("I9").Copy
                Workbooks("AHT").Worksheets("AHT").Offset(, 5).PasteSpecial xlPasteValues
            End If
        End With
    End If
Next

Any help would be really be appreciated.

Thank you

 

[GWteB]

You're trying to compare one value against multiple values at once. This results in the "subscript out of range". Furthermore, the Like operator can only be used to compare against a pattern. Finally, a worksheet has no Offset property, so this will also error out in run-time. You might try this...

For Each wb In Workbooks
    If wb.Name <> "AHT" And wb.Name <> "0005*" Then
        With Workbooks("AHT").Worksheets("AHT").Range("A2:A17")
            If Not IsEmpty(wb.Sheets(1).Range("D4")) Then
                Set c = .Find(wb.Sheets(1).Range("D4").Value, LookIn:=xlValues, LookAt:=xlPart)
                If Not c Is Nothing Then
                Do
                    wb.Sheets(1).Range("I9").Copy
                    Workbooks("AHT").Worksheets("AHT").Cells(c.Row, 5).PasteSpecial xlPasteValues
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing
            End If
        End With
    End If
Next

 

[BenGee]

Appreciate your feedback. Though slightly embarrassing I missed the offset on the worksheet!

You're code makes more sense and thank you. However the subscript

With Workbooks("AHT").Worksheets("AHT").Range("A2:A17")

flags up as out of range.

I thought this may be due to how I start the IF statement

If wb.Name <> "AHT"

so removed this, and subsequently nothing happened. Additionally, I've tried adding the full workbook name "AHT.xlsm" but again nothing happens. To clarify, by nothing I mean the code doesn't execute nor do I encounter an error.

Perhaps there is something in the rest of my code which I've additionally missed or is causing confusion?

Full code;

Dim MyFolder As String
Dim MyFile As String
Dim WB As Workbook
Dim MyRange As Range
Dim c As Range

Application.ScreenUpdating = False
MyFolder = "\Test\Data\" & Range("A1")
MyFile = Dir(MyFolder & "\*.xls")
Do While MyFile <> ""
Workbooks.Open filename:=MyFolder & "\" & MyFile
MyFile = Dir
Loop

For Each WB In Workbooks
If WB.Name <> "AHT" And WB.Name <> "0005*" Then
With WB.Sheets(1)
LastRow = .Range("C" & .Rows.Count).End(xlUp).Row
.Range("H9:H" & LastRow).Formula = "=E9-D9"
.Range("H9:H" & LastRow).NumberFormat = "hh:mm:ss"
.Range("I9").Formula = "=SUMIF(C9:C1000,""CALL FOLLOW UP"",H9:H1000)"
.Range("I9").NumberFormat = "hh:mm:ss"
End With
End If
Next


For Each WB In Workbooks
With Workbooks("AHT").Sheets("AHT").Range("A2:A17")
If Not IsEmpty(WB.Sheets(1).Range("D4")) Then
Set c = .Find(WB.Sheets(1).Range("D4").Value, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
Do
WB.Sheets(1).Range("I9").Copy
Workbooks("AHT").Sheets("AHT").Cells(c.Row, 5).PasteSpecial xlPasteValues
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
End If
End With
Next

Application.ScreenUpdating = True

I appreciate your support so far and any further suggestions with the above. Thank you

 

[GWteB]

However the subscript

With Workbooks("AHT").Worksheets("AHT").Range("A2:A17")

flags up as out of range.

This can mean two things: either the AHT workbook is not open, or the AHT workbook does not have a worksheet named AHT.

Replace the last part of your code with the following, it should work. If you have your code in a module within the AHT workbook, you may replace Workbooks("AHT") with ThisWorkbook.Name

    Dim oWbSrc  As Workbook     'Source workbook
    Dim oWbDest As Workbook     'Destination workbook
    Dim oWsDest As Worksheet    'Destination worksheet
    Dim c       As Range
    
    Set oWbDest = Workbooks("AHT")
    Set oWsDest = oWbDest.Worksheets("AHT")
    
    For Each oWbSrc In Workbooks
        If oWbSrc.Name <> "AHT" And oWbSrc.Name <> "0005*" Then
            With oWsDest.Range("A2:A17")
                If Not IsEmpty(oWbSrc.Sheets(1).Range("D4")) Then
                    Set c = .Find(oWbSrc.Sheets(1).Range("D4").Value, LookIn:=xlValues, LookAt:=xlPart)
                    If Not c Is Nothing Then
                        Do
                            oWbSrc.Sheets(1).Range("I9").Copy
                            oWsDest.Range("E" & c.Row).PasteSpecial xlPasteValues
                            Set c = .FindNext(c)
                        Loop While Not c Is Nothing
                    End If
                End If
            End With
        End If
    Next

 

[BenGee]

Thanks for all your help! I really appreciate it.

For some reason, the workbook "AHT" continues to be out of range (not the worksheet). I added in the full name, "AHT.xlsm" which seemed to fix the issue. However the code took >20mins to execute.

I suspect it's something my end so have decided to take a different approach, which is;

            .Range("J9").Value = .Range("D4").Value
            .Range("I9:J9").Copy
            Workbooks("AHT.xlsm").Sheets("Temp").Range("A1" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Thanks again for your help

 

[GWteB]

Glad to help & thanks for the feedback.

I added in the full name, "AHT.xlsm" which seemed to fix the issue.

In particular that's what I've overlooked , apologies

However the code took >20mins to execute.

Repetitive copy paste actions on worksheets can sometimes be very inefficient (ie time-consuming).