VBA遍历工作表Column A触发424错误，求代码修正与批量生成工作簿指导

问题描述 #

• 遍历当前工作簿中SCHOOLS工作表的A列所有单元格，按A列值分组（如所有值为1的行），复制对应行中A列以外的内容到新模板工作簿；
• 同时遍历同一工作簿中另外2个工作表的A列，按相同值将数据粘贴到模板指定区域；
• 当前代码执行到For x = 7时触发424 object required错误；
• 预期效果：完成一组值处理后，模板以B29单元格值命名保存并关闭，重复流程生成约300个独立工作簿。

当前错误代码 #

Sub NewFormPerSchool()

Dim wbTarget As Workbook
Dim wbCurrent As Workbook

Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Ws4 As Worksheet
Dim Ws5 As Worksheet

Set wbCurrent = ActiveWorkbook
Rem For Each w In wbCurrent.Worksheets: MsgBox "'" & w.Name & "'": Next
Set wbTarget = Application.Workbooks.Open("H:\VBA\Wendie\6.9\Working\~TEMPLATE.xlsm")

Set Ws1 = wbCurrent.Worksheets("SCHOOLS")
With Ws1
For x = 7 To Ws.Cells(Rows.Count, 7).End(xlUp).Row
        Set wbTarget = wb.Sheets("Sheet 1")
        wbTarget.myName = Ws.Cells(x, 8).Value
        Sheets.FillAcrossSheets Ws.Range("1:7")
        Ws.Rows(x).Copy curWS.Range("B29")
    Next x
End With

代码修正与逻辑解释 #

错误原因分析 #

1. Ws.Cells(...)中的Ws未定义，应使用已声明的Ws1；
2. 错误将wbTarget（工作簿对象）重新赋值为工作表，导致类型不匹配；
3. curWS未声明定义，属于未初始化的对象；
4. 代码仅逐行处理数据，未实现按A列值分组的逻辑；
5. 缺少另外两个工作表的数据处理逻辑，以及模板保存关闭的流程。

修正后的完整代码 #

Sub NewFormPerSchool()
    Dim wbCurrent As Workbook
    Dim wbTemplate As Workbook
    Dim wsSchools As Worksheet
    Dim wsOther1 As Worksheet
    Dim wsOther2 As Worksheet
    Dim wsTemplateSheet As Worksheet
    Dim lastRow As Long
    Dim schoolId As Variant
    Dim uniqueSchools As Collection
    Dim cell As Range
    Dim savePath As String
    
    ' 初始化当前工作簿和目标工作表
    Set wbCurrent = ActiveWorkbook
    Set wsSchools = wbCurrent.Worksheets("SCHOOLS")
    Set wsOther1 = wbCurrent.Worksheets("XXXXX") ' 替换为第一个额外工作表名称
    Set wsOther2 = wbCurrent.Worksheets("YYYYY") ' 替换为第二个额外工作表名称
    savePath = "H:\VBA\Wendie\6.9\Working\Output\" ' 输出文件夹，需提前创建
    
    ' 获取SCHOOLS表A列的唯一分组值（从第7行开始）
    Set uniqueSchools = New Collection
    On Error Resume Next
    lastRow = wsSchools.Cells(Rows.Count, "A").End(xlUp).Row
    For Each cell In wsSchools.Range("A7:A" & lastRow)
        If Not IsEmpty(cell.Value) Then
            uniqueSchools.Add cell.Value, Key:=CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0
    
    ' 遍历每个唯一分组值
    For Each schoolId In uniqueSchools
        ' 打开干净的模板工作簿
        Set wbTemplate = Application.Workbooks.Open("H:\VBA\Wendie\6.9\Working\~TEMPLATE.xlsm")
        Set wsTemplateSheet = wbTemplate.Worksheets("Sheet 1") ' 模板中的目标工作表
        
        ' 处理SCHOOLS表：复制匹配行的B列至行尾内容到模板B列起始区域
        lastRow = wsSchools.Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In wsSchools.Range("A7:A" & lastRow)
            If cell.Value = schoolId Then
                wsSchools.Range(cell.Offset(0, 1), cell.End(xlToRight)).Copy _
                    wsTemplateSheet.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            End If
        Next cell
        
        ' 处理第一个额外工作表：复制匹配行到模板D列起始区域（可自行调整目标列）
        lastRow = wsOther1.Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In wsOther1.Range("A7:A" & lastRow)
            If cell.Value = schoolId Then
                wsOther1.Range(cell.Offset(0, 1), cell.End(xlToRight)).Copy _
                    wsTemplateSheet.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
            End If
        Next cell
        
        ' 处理第二个额外工作表：复制匹配行到模板F列起始区域（可自行调整目标列）
        lastRow = wsOther2.Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In wsOther2.Range("A7:A" & lastRow)
            If cell.Value = schoolId Then
                wsOther2.Range(cell.Offset(0, 1), cell.End(xlToRight)).Copy _
                    wsTemplateSheet.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)
            End If
        Next cell
        
        ' 保存并关闭模板工作簿
        Dim saveName As String
        saveName = wsTemplateSheet.Range("B29").Value
        If saveName <> "" Then
            wbTemplate.SaveAs savePath & saveName & ".xlsm"
        Else
            ' 若B29为空，用分组ID作为兜底名称
            wbTemplate.SaveAs savePath & "School_" & schoolId & ".xlsm"
        End If
        wbTemplate.Close SaveChanges:=False
    Next schoolId
    
    MsgBox "批量生成完成！"
End Sub

关键逻辑解释 #

1. 获取唯一分组值：利用Collection的唯一性特性，收集A列所有不重复的值，避免重复处理同一分组；
2. 模板复用：每个分组重新打开模板，确保每次处理都是基于干净的初始模板；
3. 精准数据复制：针对每个工作表，筛选出A列值匹配的行，仅复制A列以外的内容到模板对应区域；
4. 安全保存机制：优先用模板B29的值命名文件，为空时自动用分组ID兜底，避免命名错误；
5. 对象严格定义：所有工作簿、工作表对象均明确声明并赋值，彻底解决424对象缺失错误。

注意事项 #

• 确保输出文件夹savePath已提前创建，否则会触发保存错误；
• 替换代码中XXXXX和YYYYY为实际的另外两个工作表名称；
• 根据模板布局调整数据粘贴的目标列（示例为B、D、F列）；
• 若模板包含宏，保存时需使用.xlsm格式。

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