求助：拆分 工作表

mkill4771

我想把表格根据G列的项目值拆分成多个单独的excel工作表，工作表名称为G列的项目值,请帮我写段VBA代码

Sub SplitDataByGColumn()
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim key As Variant
    Dim cell As Range
    Dim rng As Range
   
    ' 设置当前工作表
    Set ws = ThisWorkbook.Sheets("01") ' 将 "01" 替换为你的工作表名称
   
    ' 获取G列的最后一行的行号
    lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
   
    ' 创建一个字典来存储唯一的G列值
    Set dict = CreateObject("Scripting.Dictionary")
   
    ' 遍历G列，将唯一值添加到字典中
    For Each cell In ws.Range("G2:G" & lastRow)
        If Not dict.exists(cell.Value) Then
            dict.Add cell.Value, cell.Value
        End If
    Next cell
   
    ' 遍历字典中的每个唯一值
    For Each key In dict.keys
        ' 创建一个新的工作表
        Set newWs = ThisWorkbook.Sheets.Add
        newWs.Name = key
        
        ' 复制标题行
        ws.Rows(1).Copy Destination:=newWs.Rows(1)
        
        ' 筛选并复制数据
        ws.Range("A1:M" & lastRow).AutoFilter Field:=7, Criteria1:=key
        ws.Range("A2:M" & lastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=newWs.Rows(2)
        
        ' 取消筛选
        ws.AutoFilterMode = False
    Next key
   
    ' 释放字典对象
    Set dict = Nothing
   
    MsgBox "数据拆分完成！"
End Sub
        newWs.Name = key   该句错误，怎么修改，谢谢老师

3190496160

Sub SplitDataByGColumn()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim key As Variant
    Dim cell As Range
    Dim rng As Range
   
    ' 设置当前工作表
    Set ws = ThisWorkbook.Sheets("01") ' 将 "01" 替换为你的工作表名称
    For Each sh In Sheets
        If sh.Name <> "01" Then
            sh.Delete
        End If
    Next sh
    ' 获取G列的最后一行的行号
    lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
   
    ' 创建一个字典来存储唯一的G列值
    Set dict = CreateObject("Scripting.Dictionary")
   
    ' 遍历G列，将唯一值添加到字典中
    For Each cell In ws.Range("G2:G" & lastRow)
        If cell.Value <> "" Then
            If Not dict.exists(cell.Value) Then
                dict.Add cell.Value, cell.Value
            End If
        End If
    Next cell
   
    ' 遍历字典中的每个唯一值
    For Each key In dict.keys
        ' 创建一个新的工作表
        Set newWs = ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count))
        newWs.Name = key
        
        ' 复制标题行
        ws.Rows(1).Copy Destination:=newWs.Rows(1)
        
        ' 筛选并复制数据
        ws.Range("A1:M" & lastRow).AutoFilter Field:=7, Criteria1:=key
        ws.Range("A2:M" & lastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=newWs.Rows(2)
        
        ' 取消筛选
        ws.AutoFilterMode = False
    Next key
   
    ' 释放字典对象
    Set dict = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
   
    MsgBox "数据拆分完成！"
End Sub

3190496160

08-科目汇总表-明细账表- - VBA.rar (46.22 KB, 下载次数: 1)

2025-2-17 09:14 上传

点击文件名下载附件

mkill4771

谢谢了 3190496160 老师，完美解决！