当前位置：首页>Excel>【跟我学Excel VBA】第十五课:不一样的工作表拆分

【跟我学Excel VBA】第十五课:不一样的工作表拆分

2026-11-01 23:59:30

闲来无事，今天打算再来一波。

工作表拆分，相信网络上一定有相当多的版本，但是我今天展示的版本，基本上没有人展示过，不信我们走着瞧！

首先，我们来看数据源及需求：

要求：

1、按年度将本工作表进行拆分，每个年度以文件单独存在；

2、保留表头1-3行的格式不变。

要求1我们先不说，先说要求2，保留格式这条。为了达成这个需求，我们可以将此表格复制一份空表作为模板，这样的话，格式就完全保留了。如下图：

解题思路：

1、将不同年度的商品明细全部单独放置一个数组中；

2、循环年度个数，同时复制模板并另存为文件，同时将每个数组的数据清单放入单元格中，并设置格线。

难点：

1、有多少个年度未知，那么我们需要多少个数组呢？如果有100个年度，我们就要定义100个数组么？

2、怎样将数据放入对应的数组？

今天，数组嵌套数组、字典数组通通上马，让大家明白，原来数组还可以这样用。说多了无用，直接上代码！！

大家可以复制以下代码，并模拟做一个同样的数据源表，赶快试一试吧。

Sub 工作表拆分的数组嵌套解法()    Application.ScreenUpdating = False    Dim d As New Dictionary    Dim dic() As New Dictionary    Dim brr(1 To 4000, 1 To 11)    '已知每个年度的产品将不会超过4000    Dim arrResult()    Dim arrData As Variant    Dim iRow As Integer, wbk As Workbook    Dim i As Integer, x As Integer    Dim n As Integer, k As Integer, iPerRow As Integer    With Sheet4  '指向数据源        iRow = .Range("a65536").End(xlUp).Row        arrData = .Range("a4:k" & iRow).Value        For i = 1 To UBound(arrData)            If d.Exists(arrData(i, 4)) = False Then                n = n + 1                d(arrData(i, 4)) = n   'n用于记录有多少个年度                ReDim Preserve arrResult(1 To n)                arrResult(n) = brr      '重点，将一数组装入另一数组                ReDim Preserve dic(1 To n) As New Dictionary  '用数组字典记录每个年度有多少条记录            End If            k = d(arrData(i, 4))    '取得第几位的年度            dic(k)(arrData(i, 4)) = dic(k)(arrData(i, 4)) + 1    '记录有多少行            iPerRow = dic(k)(arrData(i, 4))     '取得此行数            For x = 1 To UBound(arrData, 2)                arrResult(k)(iPerRow, x) = arrData(i, x)    '第几个嵌套数组的某行取值            Next x        Next i    End With    If n > 0 Then   '当年度数大于0时        For i = 1 To n            Sheet5.Copy            Set wbk = ActiveWorkbook            wbk.SaveAs ThisWorkbook.Path & "\" & d.Keys(i - 1) & ".xls", xlNormal    '存为03格式，要加格式参数            wbk.ActiveSheet.Range("a4").Resize(dic(i).Items(0), 11) = arrResult(i)            Call SetFormat(wbk.ActiveSheet.Range("a4").Resize(dic(i).Items(0), 11))            wbk.Close True        Next i    End If    Application.ScreenUpdating = TrueEnd SubPublic Sub SetFormat(rg As Range)   '设置格式    With rg        .Borders.LineStyle = 1        .HorizontalAlignment = xlCenter        .VerticalAlignment = xlCenter        .ShrinkToFit = True    End WithEnd Sub