Excel VBA 将工作表按列拆分且生成新工作簿

FireSql

已于 2024-01-31 14:58:27 修改

阅读量1.3k

点赞数 8

文章标签： excel

于 2024-01-31 14:37:37 首次发布

本文链接：https://blog.csdn.net/zylfish/article/details/135952586

版权

文章描述了一个使用VBA脚本在Excel中自动处理的需求，根据业务员名字创建或更新工作簿，确保每个业务员对应的工作表存在且名称正确。脚本通过字典结构管理和操作数据，包括查找、添加和复制工作表内容。

摘要由CSDN通过智能技术生成

需求：已有一张总表，需要按业务员名字生成相应的工作簿，里面的工作表（sheet）命名为特定的名称。如果文件夹中已经有这个业务员工作簿且已经有同名工作表，则更新这个工作表；如果有这个业务员工作簿但没有同名工作表，则在里面新建一个工作表。

源表格：

效果：

Sub splitSht()
Dim sht As Worksheet
Dim D As Object
Dim j As Integer
Dim t
Dim SourceSht, KeyColumn, Filepath, TargetSht As String
    
    SourceSht = "销售金额" '源sheet表，即总的明细表sheet名称，命名为SourceSht
    KeyColumn = "B"  '关键列，业务员所在列，即拆分数据的依据，命名为KeyColumn
    TargetSht = "销售明细" '目标sheet表，即分表里需要粘贴到的目标sheet名称，命名为TargetSht
    Filepath = "D:\桌面文件\VBA试验\业务员分表\"   '业务员分表所在的文件夹路径，命名为Filepath
    
    t = Timer  '获取程序开始前的时间
    Set sht = ThisWorkbook.Worksheets(SourceSht)
    Set D = CreateObject("scripting.dictionary")  '创建一个字典，命名为D
    With sht
        rrow = .Range(KeyColumn & "65535").End(xlUp).Row '从关键列的最大行数65535往上数，获取有数据的最后一行的行数
        For i = 2 To rrow  '从第二行到最后一行，循环进行
            strr = .Range(KeyColumn & i).Value  '获取关键列的当前行所在单元格的数值，即当前业务员的名字，命名为strr
            If Not D.exists(strr) Then  '判断当前业务员strr是否已经在字典D中，如果不在，则
                D.Add strr, .Range("A1").Resize(1, 30)  '第一步，将A1所在行（即表头）添加进字典D中。.Range("A1").Resize(1, 30)指以A1为基准向下向右获取数据，向下获取1行（含本行），向右获取30列（含本列）的数据
                Set D.Item(strr) = Union(D.Item(strr), .Range("A" & i).Resize(1, 30))  '第二步，将业务员名字（键）对应的信息（值）更新为表头和该业务员strr所在行的合集，即添加业务员所在行
            Else
                Set D.Item(strr) = Union(D.Item(strr), .Range("A" & i).Resize(1, 30)) '如果strr已在字典D中，则不需要第一步添加表头，直接进行第二步添加该业务员名字strr所在行
            End If
        Next
        k = D.keys '键=业务员名字
        i = D.items '值=所有含有该业务员名字的行的合集
        For j = 0 To D.Count - 1
            If Not FileFolderExists(Filepath & k(j) & ".xlsx") Then '如果文件夹下没有该业务员工作簿
                Workbooks.Add  '新建一个工作簿
                ActiveWorkbook.SaveAs Filename:=Filepath & k(j) & ".xlsx"  '将新工作簿命名为业务员名字。格式：文件夹路径 + 业务员名字 + .xlsx
                Workbooks.Open Filename:=Filepath & k(j) & ".xlsx"  '打开命名后的业务员工作簿
                Workbooks(Filepath & k(j) & ".xlsx").Activate  '将业务员工作簿设置为活动工作簿
                i(j).Copy ActiveWorkbook.Worksheets(Sheet1).Range("A1") '将字典里的内容粘贴到业务员工作簿里默认生成的sheet1表，从A1单元格开始粘贴
                ActiveWorkbook.Worksheets(Sheet1).Cells.EntireColumn.AutoFit  '调整粘贴后的格式，自适应列宽
                ActiveWorkbook.Worksheets(Sheet1).Name = TargetSht  '将默认的sheet1表重命名为想要的名称
                ActiveWorkbook.Save  '保存业务员分表
                ActiveWorkbook.Close  '关闭业务员分表
            Else
                Workbooks.Open Filename:=Filepath & k(j) & ".xlsx"  '打开该业务员工作簿
                Workbooks(Filepath & k(j) & ".xlsx").Activate  '将业务员工作表设置为活动工作簿
                    If Not blnSheetExist1(TargetSht) Then  '如果业务员工作簿中没有目标sheet表
                        ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)  '在已有的工作表后面新增一个工作表，默认的表名为“Sheet1"
                        i(j).Copy ActiveWorkbook.Worksheets("Sheet1").Range("A1") '将字典里的内容粘贴到业务员工作簿里默认生成的sheet1表，从A1单元格开始粘贴
                        ActiveWorkbook.Worksheets("Sheet1").Cells.EntireColumn.AutoFit  '调整粘贴后的格式，自适应列宽
                        ActiveWorkbook.Worksheets("Sheet1").Name = TargetSht '将默认的sheet1表重命名为想要的名称
                        ActiveWorkbook.Save  '保存业务员分表
                        ActiveWorkbook.Close  '关闭业务员分表
                    Else
                        ActiveWorkbook.Worksheets(TargetSht).UsedRange.Clear '清空目标sheet表的内容和格式
                        i(j).Copy ActiveWorkbook.Worksheets(TargetSht).Range("A1") '将字典里的内容粘贴到目标sheet表，从A1单元格开始粘贴
                        ActiveWorkbook.Worksheets(TargetSht).Cells.EntireColumn.AutoFit  '调整粘贴后的格式，自适应列宽
                        ActiveWorkbook.Save  '保存业务员分表
                        ActiveWorkbook.Close  '关闭业务员分表
                    End If
            End If
        Next
    End With
    MsgBox "程序运行完成，共耗时：" & Timer - t & "秒"  '用程序结束后的时间减掉开始前的时间，获取程序运行耗时，并弹出输出框显示
End Sub

'此函数用于判断工作簿是否存在
Public Function FileFolderExists(strFullPath As String) As Boolean

    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
    On Error GoTo 0

End Function

'此函数用于判断工作表是否存在
Function blnSheetExist1(ByVal strSheetName As String) As Boolean
    Dim objSht
    
    For Each objSht In ActiveWorkbook.Sheets
        If UCase$(objSht.Name) = UCase$(strSheetName) Then
            blnSheetExist1 = True
            Exit For
        End If
    Next
End Function

1. 每一行都添加了注释，因为是帮同事写的，便于不懂任何代码的人理解。我自己也是小白，上面的代码是参考别人的代码改出来的，通过百度搜索想实现的功能，把好几段代码合在一起。

2. 开头放了几个变量，用空行分隔开，方便根据表格修改。