Excel VBA: Find data, loop through multiple worksheets, copy specific range of cells

Question

I am creating a macro for a file that will be distributed to a team of people; the function is supposed to be able to pull the person's name from a different cell (in Variable B), search for that value in another workbook with multiple sheets (Variable X), and if found copy a specific range of cells from Workbook X to Workbook B.

I am having trouble with the following code:

Sub Pull_data_Click()

Dim A As Variant 'defines name from first subroutine
Dim B As Workbook 'defines destination file
Dim X As Workbook 'defines existing report file as source
Dim Destination As Range 'defines destination range of data pulled from report
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range

A = Workbooks("filenameB.xlsm").Worksheets("Summary").Range("A1").Value 'constant variable, does not change
Set B = Workbooks("filenameB.xlsm") 'constant variable, does not change
Set X = Workbooks.Open("filenameX.xlsm") 'dependent variable, new name for each new report
Set Destination = Workbooks("filenameB.xlsm").Worksheets("Input").Range("B2:S2") 'Range changes for each iteration, rows increase by 1

'check if name is entered
If A = "" Then
MsgBox ("Your name is not visible; please start from the Reference tab.")
B.Worksheets("Reference").Activate
Exit Sub
End If

With X.Worksheets
For Each ws In X.Worksheets
Set rng = Cells.Find(What:=A, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            ActiveCell.Activate
            ActiveSheet.Range("$A$2:$DQ$11").AutoFilter Field:=1, Criteria1:=A
            Range("A7:CD7").Select
            Selection.Copy
            B.Activate
            Destination.Activate
            Destination.PasteSpecial Paste:=xlPasteValues

Next ws
End With


Application.ScreenUpdating = False

End Sub

It is able to compile successfully and has no run-time errors, and when it runs it seems to be looping through the worksheets correctly...but it is pasting the wrong information. Is there anything in this I haven't set up properly?

Answer 1

This is NOT tested. I am taking a stab at what I think you want to do. You're filtering A2 to DQ11 so that's where I set the find range. And you're pasting to B2 to S2 and that's only 11 columns wide so that's the range of data I am grabbing. Since you're pasting values (no formatting needed), I am setting the destination range to the source range directly, instead of copy/paste.

Again, untested but I can try to help with errors. I am anticipating range errors XD In short, make backups before you try my code.

Also, not sure if you expect to find data in every sheet. If so, you can't set the destination range as a constant (B2:S2) because the newer data will just overwrite the existing (unless that's what you want). You might consider adding error checking.

Finally, a tangent, but you've been really awesome taking comments and suggestions then doing the research to figure it all out and come back with new questions ^_^

Sub Pull_data_Click()    
Dim A As Variant 'defines name from first subroutine
Dim B As Workbook 'defines destination file
Dim X As Workbook 'defines existing report file as source
Dim Destination As Range 'defines destination range of data pulled from report
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Variant
Dim copyRng As Variant
Dim fRow As Long

Application.ScreenUpdating = False

Set B = Workbooks("filenameB.xlsm") 'constant variable, does not change
Set X = Workbooks.Open("filenameX.xlsm") 'dependent variable, new name for each new report
'once you set a wordbook, you can use it ^_^
A = B.Worksheets("Summary").Range("A1").Value 'constant variable, does not change
Set Destination = B.Worksheets("Input").Range("B2:S2") 'Range changes for each iteration, rows increase by 1

'check if name is entered
If A = "" Then
MsgBox ("Your name is not visible; please start from the Reference tab.")
B.Worksheets("Reference").Activate
Exit Sub
End If


For Each ws In X.Worksheets
with ws.range("A:A")
On Error Resume Next '<---add
Set rng = .Find(What:=A, After:=ActiveCell, LookIn:=xlValues, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

            fRow = rng.Row
            Set copyRng = ws.Range(Cells(fRow, 1), Cells(fRow, 18)) 'i think you want 18 because you're pasting to a range that is 18 cols wide
            Destination = copyRng
end with '<-- move it here            
Next ws

Application.ScreenUpdating = True
end sub