VBA 根据表格指定列拆分多sheet

一. 需求

⏹ 根据部分列，拆分数据到多个sheet页

---

二. 代码

⏹ 重点代码摘要

• CreateObject("scripting.dictionary")：创建一个字典对象，相当于Java中的Map
• Dim aRef() As String：定义一个存储字符串类型的数组
• ReDim aRef(1 To UBound(aData))：在声明数组时不指定大小,而在后续需要时再使用ReDim语句来动态调整数组的大小。
• .Parent.UsedRange：根据用户所选范围选中包含该范围的父级工作表，然后通过UsedRange属性来获取该工作表中已经使用的单元格范围。
• 2维数组aData的数据格式

  ' aData
  [
     ["年份", "日期", "部门"],
     ["2008年", "1月", "客服"],
     ["2009年", "2月", "财务"]
     ......
  ]
  

  lngColCount = UBound(aData, 2)：获取2维数组中，第2维数组的长度 。

⏹ VBA代码

Sub SplitShts()

    Dim d As Object, sht As Worksheet
    Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&
    Dim rngData As Range, rngGist As Range
    Dim lngTitleCount&, lngGistCol&, lngColCount&
    Dim rngFormat As Range, strYesOrNo As String
    ' 定义一个存放字符串类型数据的数组
    Dim aRef() As String
    Dim strKey As String, strTemp As String
    ' 忽略错误，程序继续运行
    On Error Resume Next 
    
    ' 创建了一个字典对象(相当于java中的Map)
    Set d = CreateObject("scripting.dictionary")
    
    ' 用户选择的拆分依据列
    Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
    ' 拆分依据列的列标
    lngGistCol = rngGist.Column
    ' 用户设置总表的标题行数
    lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？", Default:=1))
    
    If lngTitleCount < 0 Then 
        MsgBox "标题行数不能为负数，程序退出。": Exit Sub
    End If
    
    ' 让用户选择是否在分表保留总表的格式
    strYesOrNo = MsgBox("是否需要在分表保留总表格式？", vbYesNo)
    
    ' 总表的数据区域
    Set rngData = rngGist.Parent.UsedRange
    ' 总表的单元格区域用于粘贴总表格式 
    Set rngFormat = rngGist.Parent.Cells
   
    ' 2维数组aData的数据格式
    ' [
    '   ["年份", "日期", "部门"],
    '   ["2008年", "1月", "客服"],
    '   ["2009年", "2月", "财务"]
    '   ......
    ' ]
    aData = rngData.Value
    ' 计算依据列在数组中的位置
    lngGistCol = lngGistCol - rngData.Column + 1
    ' 数据源的列数(2维数组中,第2维数组的长度)
    lngColCount = UBound(aData, 2)
    
    ' 关闭代码执行时屏幕刷新
    Application.ScreenUpdating = False
    ' 不允许显示警告对话框
    Application.DisplayAlerts = False
    
    ' 在VBA中,可以在声明数组时不指定大小,而在后续需要时再使用ReDim语句来动态调整数组的大小。
    ReDim aRef(1 To UBound(aData))
    
    For i = 1 To UBound(aData) 
    
        ' 处理依据列的异常值，空白/错误值/整行空白等
        If IsError(aData(i, lngGistCol)) Then
            aRef(i) = "错误值"
        ElseIf aData(i, lngGistCol) = "" Then
        
            ' 判断是否整行数据为空
            strTemp = "" 
            For j = 1 To lngColCount
                strTemp = strTemp & aData(i, j)
            Next
            
            ' 如果整行为空
            If strTemp = "" Then 
                aRef(i) = "整行空白"
            Else
                aRef(i) = "空白单元格"
            End If
        Else
            strKey = aData(i, lngGistCol)
            aRef(i) = strKey
        End If
    Next
    
    For i = lngTitleCount + 1 To UBound(aData)
    
        ' 从数组中获取部门名称
        strKey = aRef(i)
        
        ' 若满足条件,则跳出本次循环
        If strKey = "整行空白" Then
            Exit For
        End If
        
        ' 字典中存在关键字时则跳过本次循环
        If d.exists(strKey) Then
            Exit For
        End If
        
        d(strKey) = ""
        
        ' 声明一个结果数组
        ReDim aResult(1 To UBound(aData), 1 To lngColCount) 
        
        k = 0
        
        ' 遍历数据源
        For x = lngTitleCount + 1 To UBound(aData) 
            strTemp = aRef(x)
            ' 如果记录符合条件，则装入结果数组
            If strTemp = strKey Then 
                k = k + 1
                For j = 1 To lngColCount
                    aResult(k, j) = aData(x, j)
                Next
            End If
        Next
        
        ' 删除旧表
        For Each sht In ActiveWorkbook.Worksheets 
            If sht.Name = strKey Then sht.Delete
        Next
        
        ' 新建一个工作表
        With Worksheets.Add(, Sheets(Sheets.Count))
        
            .Name = strKey
            ' 设置单元格为文本格式
            .Range("a1").Resize(UBound(aData), lngColCount).NumberFormat = "@"
            
            ' 标题行
            If lngTitleCount > 0 Then 
                .Range("a1").Resize(lngTitleCount, lngColCount) = aData
            End If
            
            ' 写入数据
            .Range("a1").Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult
            
            ' 如果用户选择保留总表格式
            If strYesOrNo = vbYes Then 
                rngFormat.Copy
                ' 复制粘贴总表的格式
                .Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                ' 删除多余的格式单元格 
                .Range("a1").Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete
            End If
            
            .Range("a1").Select
        End With
    Next
    
    ' 回到总表
    rngData.Parent.Activate 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    ' 释放
    Set d = Nothing
    Set rngData = Nothing
    Set rngGist = Nothing
    Set rngFormat = Nothing
    Erase aData: Erase aResult
    
    MsgBox "数据拆分完成！"
    
End Sub