VBA - 如何在 Excel 工作簿之间复制单元格（工作簿名称更改的地方）？

Question

我正在寻找有关如何编写执行以下操作的宏的建议。我想它很容易做到，但我无法弄清楚。提前致谢！

开始

1. 在活动工作表中（在工作簿中，我在 [标题更改但每次格式相同] 中运行此宏），复制单元格 B9。粘贴到我正在使用的另一个工作簿的下一个空白行的 A 列[每次运行此过程时可以具有相同的标题，或者只是打开的另一个工作簿]
2. 在活动工作表中（在我运行此宏的工作簿中），复制单元格 B8。粘贴到上面标识的行的 B 列中。
3. 在活动工作表中（在我运行此宏的工作簿中），复制单元格 B12。粘贴到上面标识的行的 C 列中。
4. 在活动工作表中（在我运行此宏的工作簿中），复制单元格 A17:E17。粘贴到上面标识的行的 D:H 中。
5. 在活动工作表中（在我运行此宏的工作簿中），复制单元格 A17:E17。粘贴到上面标识的行的 D:H 中。
6. 在活动工作表中（在我运行此宏的工作簿中），复制单元格 G17:N17。粘贴到上面标识的行的 I:P 中。

结束

鉴于我缺乏 vba 编码能力，我正在尝试录制宏然后进行调整。我已经尝试了尽可能多的选项，因为我可以在谷歌上找到。以下似乎是最好的，但不起作用。 （注意：我从上面选择的第 1 点开始选择 B9）。

Sub Copy_Timesheet()
'
' Copy_Timesheet Macro
'

'
Selection.Copy
Windows("WorkbookB").Activate
Find_Blank_Row()
Dim BlankRow As Long
BlankRow = Range("A65536").End(xlUp).Row + 1
Cells(BlankRow, 1).Select
ActiveCell.Offset(1, 0).Range("A1").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
ActiveCell.Offset(3, 0).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("WorkbookB").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
ActiveCell.Offset(-4, 0).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("WorkbookB").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
ActiveCell.Offset(9, -1).Range("A1:E1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("WorkbookB").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
ActiveCell.Offset(0, 6).Range("A1:H1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("WorkbookB").Activate
ActiveCell.Offset(0, 5).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

Answer 1

现在您已经在生成代码方面付出了一些努力，这里是您所说的内容的重构版本。 （我没有检查这是否与您实际录制的内容相匹配，但您不厌其烦地录制某些内容这一事实表明您并不是懒得自己做。）

Sub Copy_Timesheet()
    'Set up some objects to make life easier in the rest of the code
    ' "the active sheet (in the workbook I am running this macro in)"
    Dim wsSrc As Worksheet
    Set wsSrc = ThisWorkbook.ActiveSheet
    'the sheet in the other workbook
    Dim wsDst As Worksheet
    Set wsDst = Workbooks("WorkbookB").Worksheets("destination_sheet_name") 'change sheet name to whatever you need

    Dim BlankRow As Long
    'Fully qualify ranges so that we ensure we are working with the sheet we expect to be
    'Use Rows.Count rather than 65536 just in case we are working in a recent workbook that allows 1048576 rows
    BlankRow = wsDst.Range("A" & wsDst.Rows.Count).End(xlUp).Row + 1

    'In the active sheet (in the workbook I am running this macro in [Title changes but same formatting each time]), copy cell B9. Paste in column A on the next blank row of the other workbook I am using [Can have the same title every time I run this process, or just be the only other workbook open]
    wsDst.Range("A" & BlankRow).Value = wsSrc.Range("B9").Value    

    'In the active sheet (in the workbook I am running this macro in), copy cell B8. Paste in column B of the row identified above.
    wsDst.Range("B" & BlankRow).Value = wsSrc.Range("B8").Value    

    'In the active sheet (in the workbook I am running this macro in), copy cell B12. Paste in column C of the row identified above.
    wsDst.Range("C" & BlankRow).Value = wsSrc.Range("B12").Value    

    'In the active sheet (in the workbook I am running this macro in), copy cells A17:E17. Paste in D:H of the row identified above.
    wsDst.Range("D" & BlankRow & ":H" & BlankRow).Value = wsSrc.Range("A17:E17").Value    

    'In the active sheet (in the workbook I am running this macro in), copy cells A17:E17. Paste in D:H of the row identified above.
    'No need to do this - we just did it

    'In the active sheet (in the workbook I am running this macro in), copy cells G17:N17. Paste in I:P of the row identified above.
    wsDst.Range("I" & BlankRow & ":P" & BlankRow).Value = wsSrc.Range("G17:N17").Value    

End Sub

Answer 2

Sub copysheet()
Dim wb  As Workbook
Dim wb1 As Workbook

application.screenupdating=False
application.DisplayAlerts=False
On error goto resetsettings

MyPath = "C:\Users\foo\" 'The folder containing the files you want to use
MyExtension = "*.xlsx" 'The extension of the file you want  to use

Myfile = Dir(MyPath & MyExtension)
Set wb = ThisWorkbook
While Myfile <> ""
Set wb1 = Workbooks.Open(MyPath & Myfile)
lr = wb1.Sheets(1).Range("A1:A" & Rows.Count).End(xlUp).Row + 1
wb.Sheets(1).Range("B9").Copy Destination:=wb1.Sheets(1).Range("A" & lr)
wb.Sheets(1).Range("B8").Copy Destination:=wb1.Sheets(1).Range("B" & lr)
wb.Sheets(1).Range("B12").Copy Destination:=wb1.Sheets(1).Range("C" & lr)
wb.Sheets(1).Range("A17:E17").Copy Destination:=wb1.Sheets(1).Range("D" & lr & ":H" & lr)
wb.Sheets(1).Range("G17:N17").Copy Destination:=wb1.Sheets(1).Range("I" & lr & ":P" & lr)
wb1.close Savechanges:=True
Myfile = Dir
Wend
ResetSettings:
application.screenupdating=True
application.DisplayAlerts=True
End Sub

此宏将遍历文件夹中的所有 Xlsx 文件，并对文件进行上述更改并关闭它们。