Excel VBA循环批量复制两个独立单元格至新工作簿问题

需求 #

编写Excel VBA循环，批量将两个独立列（D列、AA列）的对应行数据，一次性复制到模板工作簿的指定单元格，另存为新工作簿。

原代码及问题 #

以下是初始代码，可运行但会重复获取相同单元格数据：

Dim ObjWorkbook As Workbook, PerWorkbook As Workbook
Set ObjWorkbook = Workbooks.Open( _
"A:\Master PAYE Costs Dec 23.xlsx")

Set PerWorkbook = Workbooks.Open( _
  "A:\Name Surname-Feb24-Timesheet 1.xlsx")

Dim cRng As Range, sRng As Range, c As Range
Dim Row As Range, totalRng As Range, cell As Range
Dim strName As String, pName As String

strName = "-Feb24-Timesheet"

Dim folderPath As String

folderPath = Application.ActiveWorkbook.Path


Set cRng = ObjWorkbook.Sheets("Payroll - Nov 23").Range("AA3:AA103")
Set sRng = ObjWorkbook.Sheets("Payroll - Nov 23").Range("D3:D103")
Set totalRng = Union(cRng, sRng)


For Each Row In totalRng.Rows
  For Each cell In Row.Cells
    Debug.Print cell.Value & strName
    PerWorkbook.Sheets("Timesheet").Range("B2") = cell.Value
    PerWorkbook.Sheets("Timesheet").Range("AM4") = cell.Value
    PerWorkbook.SaveCopyAs (folderPath & "\Timesht\" & cell.Value & strName & ".xlsx")
  Next cell
Next Row

问题原因：使用Union合并两列后，遍历每行的每个单元格时，会分别处理D列和AA列的单元格，导致每次循环只赋值单个单元格到B2和AM4，重复生成相同数据的文件。

更新后代码及错误 #

修改后的代码出现语法错误，提示「Invalid cell control variable reference」，错误位置为倒数第二行的Next cell语句：

For Each Row In totalRng.Rows
  For Each cell In Row.Cells
    Debug.Print cell.Value & strName
    PerWorkbook.Sheets("Timesheet").Range("B2") = cell.Value
  Next cell
  For Each cell2 In Row.Cells
    PerWorkbook.Sheets("Timesheet").Range("AM4") = cell2.Value
  Next cell2
  'ObjWorkbook.SaveCopyAs (
  PerWorkbook.SaveCopyAs (folderPath & "\Timesht\" & cell.Value & 
strName & ".xlsx")
  Next cell
Next Row

错误原因：代码末尾多了一个Next cell，没有对应的For Each cell循环，导致循环结构不匹配，触发语法错误。

最终解决方案 #

核心逻辑：直接按行索引对应获取D列和AA列的一组数据，赋值到模板工作簿后另存为新文件，避免使用Union导致的遍历混乱。

正确代码如下：

Dim ObjWorkbook As Workbook, PerWorkbook As Workbook
Dim wsPayroll As Worksheet
Dim lastRow As Long
Dim i As Integer
Dim strName As String
Dim folderPath As String
Dim empName As String
Dim payValue As String

' 打开源数据工作簿和模板工作簿
Set ObjWorkbook = Workbooks.Open("A:\Master PAYE Costs Dec 23.xlsx")
Set PerWorkbook = Workbooks.Open("A:\Name Surname-Feb24-Timesheet 1.xlsx")
' 绑定源数据工作表
Set wsPayroll = ObjWorkbook.Sheets("Payroll - Nov 23")

strName = "-Feb24-Timesheet"
' 获取保存路径
folderPath = Application.ActiveWorkbook.Path
' 获取数据最后一行（避免固定103行的硬编码）
lastRow = wsPayroll.Cells(wsPayroll.Rows.Count, "D").End(xlUp).Row

' 从第3行开始循环到最后一行
For i = 3 To lastRow
    ' 获取D列（姓名）和AA列（薪资数据）的值
    empName = wsPayroll.Cells(i, "D").Value
    payValue = wsPayroll.Cells(i, "AA").Value
    
    ' 跳过空值，避免生成无效文件
    If empName <> "" Then
        ' 赋值到模板工作簿的指定单元格
        PerWorkbook.Sheets("Timesheet").Range("B2").Value = empName
        PerWorkbook.Sheets("Timesheet").Range("AM4").Value = payValue
        
        ' 另存为新工作簿
        PerWorkbook.SaveCopyAs folderPath & "\Timesht\" & empName & strName & ".xlsx"
    End If
Next i

' 关闭工作簿（可选，避免占用资源）
ObjWorkbook.Close SaveChanges:=False
PerWorkbook.Close SaveChanges:=False

' 释放对象
Set wsPayroll = Nothing
Set ObjWorkbook = Nothing
Set PerWorkbook = Nothing

代码说明 #

• 直接按行循环，同时获取D列和AA列的对应值，一次性完成两个单元格的赋值，避免重复操作
• 添加空值判断，跳过无数据的行，防止生成空文件名的无效文件
• 使用lastRow动态获取数据最后一行，替代固定的103行，提升代码灵活性
• 循环结束后关闭工作簿并释放对象，避免内存占用

内容的提问来源于stack exchange，提问作者Geographos