Excel VBA:查找数据，遍历多个工作表，复制特定范围的单元格 [英] Excel VBA: Find data, loop through multiple worksheets, copy specific range of cells

问题描述

我正在为将要分发给团队的文件创建宏；该功能应该能够从另一个单元格(在变量B中)提取人的名字，在具有多张工作表的另一个工作簿中搜索该值(变量X)，如果找到该值，则将特定范围的单元格从Workbook X复制到工作簿B.

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?

推荐答案

这未经测试.我对我想做的事不屑一顾.您正在将A2过滤到DQ11，所以这就是我设置 find 范围的地方.然后将B2粘贴到S2，只有11列宽，这就是我要获取的数据范围.由于您要粘贴值(无需格式化)，因此我将目标范围直接设置为源范围，而不是复制/粘贴.

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.

再次，未经测试，但我可以尝试帮助您解决错误.我预计XD会出现范围错误简而言之，请先备份，然后再尝试使用我的代码.

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.

此外，不确定是否希望在每张纸上查找数据.如果是这样，则不能将目标范围设置为常量(B2:S2)，因为较新的数据只会覆盖现有数据(除非您要这样做).您可能会考虑添加错误检查.

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

这篇关于Excel VBA:查找数据，遍历多个工作表，复制特定范围的单元格的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！