如何用VBA按数字前缀分组MainSheet数据并自动创建对应工作表

Private Sub CommandButton1_Click()
    Dim MainSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim myBook As Workbook
    Dim lastRow As Long, targetLastRow As Long
    Dim i As Long
    Dim namesColumn As Integer
    Dim prefixStr As String, sheetName As String
    
    ' 配置参数
    Set myBook = ActiveWorkbook
    Set MainSheet = myBook.Worksheets("MainSheet")
    namesColumn = 3 ' 匹配列是第三列
    
    ' 获取主表最后一行行号
    lastRow = MainSheet.Cells(MainSheet.Rows.Count, namesColumn).End(xlUp).Row
    
    ' 遍历所有数据行，跳过表头
    For i = 2 To lastRow
        ' 提取前4位前缀，转换为目标工作表名
        prefixStr = Left(MainSheet.Cells(i, namesColumn).Value, 4)
        sheetName = Right(prefixStr, 2) & "-" & Left(prefixStr, 2)
        
        ' 判断工作表是否存在，不存在则新建并复制表头
        If Not Sheet_Exists(sheetName, myBook) Then
            Set targetSheet = myBook.Worksheets.Add(After:=myBook.Worksheets("MainSheet"))
            targetSheet.Name = sheetName
            ' 复制表头行
            MainSheet.Rows(1).Copy Destination:=targetSheet.Rows(1)
        Else
            Set targetSheet = myBook.Worksheets(sheetName)
        End If
        
        ' 找到目标表的最后空行，复制当前行
        targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, namesColumn).End(xlUp).Row + 1
        MainSheet.Rows(i).Copy Destination:=targetSheet.Rows(targetLastRow)
    Next i
End Sub

' 辅助函数：判断工作表是否存在
Function Sheet_Exists(sheetName As String, wb As Workbook) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Worksheets(sheetName)
    On Error GoTo 0
    Sheet_Exists = Not ws Is Nothing
End Function

关键调整说明 #

• 修复了原代码中变量名拼写错误、工作表引用不一致、循环内重复创建工作表的逻辑问题
• 实现了指定的前缀提取和工作表名转换规则：提取第三列值前4位，拆分前后两位后反转拼接为工作表名
• 新增工作表存在性校验，仅首次匹配到对应前缀时新建工作表，同时自动复制主表表头
• 同前缀的所有行自动追加到对应工作表的末尾，不会重复复制表头，也不会漏行

使用注意 #

确保工作簿中主表名称为MainSheet、匹配规则对应的列为第三列即可直接运行；若主表表头行数不为1，可自行调整代码中复制表头的行号参数。

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