我正在尝试为以下任务编写代码，但我一直在苦苦挣扎。 我有2个工作簿，wb1和wb2。 wb1在A列中有一个包含名称列表的表，然后B-V列有我要复制到工作表的数据，其名称与A列中的名称相同，但在不同的书中（wb2）。粘贴到的位置还取决于wb2中目标工作表上的其他条件。
所以例如在wb1＆＃34; John＆＃34;是A1中的名称，切换到wb2，转到名为John的工作表，检查此工作表的单元格A4上的条件： 有3个标准：青少年，成年人或长者
如果是Teen，则将B1复制到B97，将C1复制到B135，将D1复制到B147＆amp; B190，将E4复制到B1100
如果是Adult，则将J1复制到B97，将F1复制到B135，将G1复制到B147＆amp; B190，将H4复制到B1100
如果是Elder，则将B1复制到B97，将C1复制到B135，将D1复制到B147＆amp; B190，将E4复制到B1100，将J1复制到B113，将F1复制到B1910，将G1复制到B1473＆amp; B1930，将H4复制到B1190
（以上只是一个例子，复制粘贴的单元格比上面列出的要多）
这应该为wb1的A列中的所有名称循环。
下面是宏记录给我的内容，但它没有记录标准。这两本工作簿都是开放的。
Sub Summary()
Dim wb1 As Workbook
Dim Sht As Worksheet
Dim Rng, Rng2 As Range
Set wb1= ThisWorkbook
Set Sht = MasterBook.Worksheets("Sheet")
Set Rng = Sht.Range("A2:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row)
Dim wb2 As Workbook
Dim cell As Range
For Each cell In Rng '<---Here is where my first problem is,
'not sure how to get the excel to switch to the sheet
'with the same name as in column A then check cell A4 for the criteria'
If cell.Value = "Teen" Then
Range("C12").Select
Selection.Copy
Windows("wb2.xlsx").Activate
ActiveWindow.SmallScroll Down:=81
Range("B97").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-9
Windows("wb1.xlsx").Activate
Range("D12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("wb2.xlsx").Activate
ActiveWindow.SmallScroll Down:=12
Range("B95").Select
ActiveSheet.Paste
Windows("wb1.xlsx").Activate
Range("E12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("wb2.xlsx").Activate
ActiveWindow.SmallScroll Down:=-45
Range("B47").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=63
Range("B118").Select
ActiveSheet.Paste
Windows("wb1.xlsx").Activate
Range("F12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("wb2.xlsx").Activate
ActiveWindow.SmallScroll Down:=48
Range("B163").Select
ActiveSheet.Paste
Windows("wb1.xlsx").Activate
Range("G12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("wb2.xlsx").Activate
ActiveWindow.SmallScroll Down:=-66
Range("B93").Select
ActiveSheet.Paste
Windows("wb1.xlsx").Activate
Range("H12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("wb2.xlsx").Activate
ActiveWindow.SmallScroll Down:=9
Range("B105").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=60
Range("B167").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("wb1.xlsx").Activate
Range("I12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("wb2.xlsx").Activate
ActiveWindow.SmallScroll Down:=-27
Range("B141").Select
ActiveSheet.Paste
Windows("wb1.xlsx").Activate
Range("J12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("wb2.xlsx").Activate
Range("B145").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=138
Windows("wb1.xlsx").Activate
Windows("wb2.xlsx").Activate
ActiveWindow.SmallScroll Down:=51
Range("B326").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=12
Range("B339").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "1"
Range("B317").Select
ActiveCell.FormulaR1C1 = "1"
Range("B312").Select
ActiveCell.FormulaR1C1 = "1"
Windows("wb1.xlsx").Activate
Range("K12").Select
Selection.Copy
Windows("wb2.xlsx").Activate
Range("B107").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-63
Range("B49").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-9
Windows("wb1.xlsx").Activate
Windows("wb2.xlsx").Activate
ActiveWindow.SmallScroll Down:=306
Windows("wb1.xlsx").Activate
else If cell.Value = "Adult" Then
'<-----same stuff as above for different cells copy pasted'
else If cell.Value = "Elder" Then
'<-----same stuff as above for different cells copy pasted'
end if
End Sub
此外，我不知道案例函数是否有用，而不是这里的If语句。
提前多多感谢
编辑1
我按照以下建议更改了代码
Sub Summary()
Dim wb1 As Workbook
Dim Sht As Worksheet
Dim Rng, Rng2 As Range
Dim wb2 As Workbook
Dim cell As Range
Set wb1 = ThisWorkbook
Set wb2 = Workbooks("Measure Templates.xlsx")
Set Sht = wb1.Worksheets("Summary")
Set Rng = Sht.Range("A5:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row)
For Each cell In Rng
Select Case wb2.Sheets(cell.Text).Range("A4").Value
Case "Standard Bathroom Template"
wb1.Sheet("Summary").Range("B5").Value = wb2.ActiveSheet.Range("B97") '<--- I'm getting an error here saying "Object doesn't support this property or method"
'I assume that this is not the right way to copy paste.
'I looked around but everything online uses a specific sheet name for destination
'which is not the case for me, it should be sheet with same name as in column A
wb1.Sheet("Summary").Range("C5").Value = wb2.ActiveSheet.Range("B117")
Case "Standard Kitchen Template"
wb1.Sheet("Summary").Range("B6").Value = wb2.ActiveSheet.Range("B97")
wb1.Sheet("Summary").Range("C6").Value = wb2.ActiveSheet.Range("B117")
Case "Standard Bathroom and Kitchen T"
wb1.Sheet("Summary").Range("B7").Value = wb2.ActiveSheet.Range("B97")
wb1.Sheet("Summary").Range("C7").Value = wb2.ActiveSheet.Range("B117")
End Select
Next cell
End Sub
答案 0 :(得分：0)
更新并添加了一个工作表变量（ws），它指向相关的复印表（不需要选择或激活）。
Sub Summary()
Dim wb1 As Workbook
Dim Sht As Worksheet
Dim Rng, Rng2 As Range
Dim wb2 As Workbook
Dim cell As Range
Dim ws as Worksheet
Set wb1 = ThisWorkbook
Set wb2 = Workbooks("Measure Templates.xlsx")
Set Sht = wb1.Worksheets("Summary")
Set Rng = Sht.Range("A5:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row)
For Each cell In Rng
Set ws=wb2.Sheets(cell.Text)
Select Case ws.Range("A4").Value
Case "Standard Bathroom Template"
wb1.Sheet("Summary").Range("B5").Value = ws.Range("B97").Value
wb1.Sheet("Summary").Range("C5").Value = ws.Range("B117").Value
Case "Standard Kitchen Template"
wb1.Sheet("Summary").Range("B6").Value = ws.Range("B97").Value
wb1.Sheet("Summary").Range("C6").Value = ws.Range("B117").Value
Case "Standard Bathroom and Kitchen T"
wb1.Sheet("Summary").Range("B7").Value = ws.Range("B97").value
wb1.Sheet("Summary").Range("C7").Value = ws.Range("B117").Value
End Select
Next cell
End Sub