Excel VBA:查找数据，循环多个工作表，复制特定的单元格范围

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.

我正在为一个文件创建一个宏，这个文件将被分发给一个团队;这个函数应该能够从另一个单元格(在变量B中)提取此人的名字，在另一个包含多个表(变量X)的工作簿中搜索该值，如果找到，则复制工作簿X到工作簿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?

它能够成功地编译，并且没有运行时错误，当它运行时，它似乎在正确地循环遍历工作表……但它粘贴了错误的信息。这里面有什么我没有设置好的吗?

1 个解决方案

#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.

这不是测试。我正在尝试你想做的事。将A2过滤到DQ11，这就是我设置查找范围的地方。粘贴到B2到S2只有11列宽这就是我要获取的数据范围。由于您正在粘贴值(不需要格式化)，所以我直接将目标范围设置为源范围，而不是复制/粘贴。

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.

再次，未经测试，但我可以尝试帮助错误。我正在预测范围错误XD，简而言之，在您尝试我的代码之前做备份。

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.

同样，不确定是否期望在每个表中都找到数据。如果是这样，就不能将目标范围设置为常量(B2:S2)，因为新数据只会覆盖现有数据(除非这是您想要的)。您可以考虑添加错误检查。

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

#1