根据条件复制特定的单元格，以与另一个工作簿中的条件具有相同标签的工作表(Copy specific cells based on a criteria, to sheets with same label as the criteria in another workbook)
我正在尝试为以下任务编写代码，但我一直在努力。 我有2个工作簿，wb1和wb2。 wb1有一个列A中的名称列表，然后列BV具有我要复制到与A列中名称相同但在另一本书（wb2）中的工作表的数据。 粘贴到的位置也取决于wb2中目标工作表上的另一个条件。
例如在wb1中，“John”是A1中的名字，切换到wb2，转到名为John的表格，检查此表单元格A4上的标准：有3个标准：青少年，成人或长老
如果青少年，则将B1复制到B97中，将C1复制到B135中，将D1复制到B147和B190中，将E4复制到B1100中
如果成人，则将J1复制到B97中，将F1复制到B135中，将G1复制到B147和B190中，将H4复制到B1100中
如果是老人，则将B1复制到B97中，将C1复制到B135中，将D1复制到B147和B190中，将E4复制到B1100中，将J1复制到B113中，将F1复制到B1910中，将G1复制到B1473和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此外，我不知道case函数是否有用，而不是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 SubI am trying to write a code for the following task, but I have been struggling a quite a bit. I have 2 workbooks, wb1 and wb2. wb1 has a table with a list of names in column A, then column B-V has the data I want to copy to the sheet with the same name as in column A but in a different book (wb2). The location its pasted to is also dependent on another criteria on the destination sheet in wb2.
so for example in wb1 "John" is the name in A1, switch to wb2, go to the sheet called John, check the criteria on cell A4 of this sheet: There are 3 criteria which are: Teen, adult or Elder
If Teen, then copy B1 into B97, copy C1 into B135, copy D1 into B147 & B190, copy E4 into B1100
If Adult, then copy J1 into B97, copy F1 into B135, copy G1 into B147 & B190, copy H4 into B1100
If Elder, then copy B1 into B97, copy C1 into B135, copy D1 into B147 & B190, copy E4 into B1100, copy J1 into B113, copy F1 into B1910, copy G1 into B1473 & B1930, copy H4 into B1190
(The above is just an example, there is a more cells to copy paste than listed above)
This should be looped for all names in column A of wb1.
Below is what macro record gave me, but it doesn't record the criterias. Both workbooks will be open btw.
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 SubAlso I don't know if the case function would be useful instead of the If statement here either.
Thanks a lot in advance
EDIT 1
I changed the code as suggested below
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最满意答案
已经更新并添加了一个表单变量（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 SubHave updated and added a sheet variable (ws) which points to the relevant sheet for copying (it does not need to be selected or active).
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根据条件复制特定的单元格，以与另一个工作簿中的条件具有相同标签的工作表(Copy specific cells based on a criteria, to sheets with same label as the criteria in another workbook)我正在尝试为以下任务编写代码，但我一直在努力。 我有2个工作簿，wb1和wb2。 wb1有一个列A中的名称列表，然后列BV具有我要复制到与A列中名称相同但在另一本书（wb2）中的工作表的数据。 粘贴到的位置也取决于wb2中目标工作表上的另一个条件。
例如在wb1中，“John”是A1中的名字，切换到wb2，转到名为John的表格，检查此表单元格A4上的标准：有3个标准：青少年，成人或长老
如果青少年，则将B1复制到B97中，将C1复制到B135中，将D1复制到B147和B190中，将E4复制到B1100中
如果成人，则将J1复制到B97中，将F1复制到B135中，将G1复制到B147和B190中，将H4复制到B1100中
如果是老人，则将B1复制到B97中，将C1复制到B135中，将D1复制到B147和B190中，将E4复制到B1100中，将J1复制到B113中，将F1复制到B1910中，将G1复制到B1473和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此外，我不知道case函数是否有用，而不是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 SubI am trying to write a code for the following task, but I have been struggling a quite a bit. I have 2 workbooks, wb1 and wb2. wb1 has a table with a list of names in column A, then column B-V has the data I want to copy to the sheet with the same name as in column A but in a different book (wb2). The location its pasted to is also dependent on another criteria on the destination sheet in wb2.
so for example in wb1 "John" is the name in A1, switch to wb2, go to the sheet called John, check the criteria on cell A4 of this sheet: There are 3 criteria which are: Teen, adult or Elder
If Teen, then copy B1 into B97, copy C1 into B135, copy D1 into B147 & B190, copy E4 into B1100
If Adult, then copy J1 into B97, copy F1 into B135, copy G1 into B147 & B190, copy H4 into B1100
If Elder, then copy B1 into B97, copy C1 into B135, copy D1 into B147 & B190, copy E4 into B1100, copy J1 into B113, copy F1 into B1910, copy G1 into B1473 & B1930, copy H4 into B1190
(The above is just an example, there is a more cells to copy paste than listed above)
This should be looped for all names in column A of wb1.
Below is what macro record gave me, but it doesn't record the criterias. Both workbooks will be open btw.
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 SubAlso I don't know if the case function would be useful instead of the If statement here either.
Thanks a lot in advance
EDIT 1
I changed the code as suggested below
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最满意答案
已经更新并添加了一个表单变量（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 SubHave updated and added a sheet variable (ws) which points to the relevant sheet for copying (it does not need to be selected or active).
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
发布评论