用VBA创建数据透视表

作者：iamlaosong

有个拣货报表，想先从货品信息中分离出颜色信息，再根据储位、名称和颜色创建一个数据透视表，由于数据是变化的（结构不变，记录数会变），每次重新创建很麻烦，因此想做个工具，用VBA分离颜色并创建数据透视表，供其他人使用。分离颜色的代码很好写，创建数据透视表的代码自然采用录制宏的方法最简单，代码出来后修改一下就行了。工具界面如下：

拣货单的内容如下，需要分离SKU信息中的颜色：

工具的代码如下：

'分离信息
Sub separate_information()

    On Error GoTo Err
    thisfile = ThisWorkbook.name   '本文件的名字，这样赋值就可以随便改名了
    Worksheets("系统参数").Select
    If Cells(2, 2) = "Y" Or Cells(2, 2) = "y" Then                              '导出出库文件
        Application.ScreenUpdating = True
    Else
        Application.ScreenUpdating = False
    End If

    'curdate = Cells(2, 2)
    'pos_qsh = Cells(2, 7)
    'pos_sku = Asc(Cells(3, 7)) - 64
    pos_fst = Cells(2, 7)
    pos_sku = Cells(3, 7)
    pos_sav = Cells(4, 7)
    pos_tag = Cells(5, 7)
    pos_end = Cells(6, 7)

    'If MsgBox("开始生成清分数据......", vbOKCancel, "iamlaosong") = vbCancel Then Exit Sub

    lineno = [A65536].End(xlUp).Row           '行数，文件数量

    For unit_num = 5 To lineno                 '文件循环

        datfile = Cells(unit_num, 2)                              '文件名称
        datFullName = ThisWorkbook.Path & "\" & datfile
        If Dir(datFullName, vbNormal) <> vbNullString Then
            Workbooks.Open Filename:=datFullName        '打开订单文件
            ext = Right(datfile, 3)
            If ext = "xls" Then
                MaxRow = Cells(65536, pos_sku).End(xlUp).Row
            Else
                MaxRow = Cells(1048576, pos_sku).End(xlUp).Row
            End If
        Else
            MsgBox "数据文件不存在！", vbOKOnly, "iamlaosong"
            Exit Sub
        End If

        tag_len = Len(pos_tag)
        Cells(pos_fst - 1, pos_sav) = pos_tag
        Cells(pos_fst - 1, pos_sav).Font.Bold = True

        '分离信息，取pos_tag和pos_end之间的信息
        For row1 = pos_fst To MaxRow
            'If row1 = 193 Then
            '    Debug.Print row1
            'End If
            buf = Cells(row1, pos_sku)
            m1 = InStr(1, buf, pos_tag, vbTextCompare)
            If m1 > 0 Then
                m2 = InStr(m1 + tag_len, buf, pos_end, vbTextCompare)
                buf_sel = Mid(buf, m1 + tag_len, m2 - m1 - tag_len)
            Else
                buf_sel = "notfound"
            End If
            Cells(row1, pos_sav + 0) = buf_sel
            '单元格中的数值是文本的，转换成数值型
            tmp = Cells(row1, 7)
            Cells(row1, 7) = CInt(tmp)
        Next row1
        '建立数据透视表
        pdata1 = ActiveSheet.name & "!R1C1:R" & MaxRow & "C9"
        Sheets.Add
        pdata2 = ActiveSheet.name & "!R3C1"
        ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=pdata1, _
            Version:=xlPivotTableVersion12).CreatePivotTable TableDestination:=pdata2, _
            TableName:="拣货单数据透视表", DefaultVersion:=xlPivotTableVersion12
        '设置透视表格式，表格型、无小计
        Cells(3, 1).Select
        ActiveSheet.PivotTables("拣货单数据透视表").PivotFields("拣货储位").Subtotals(1) = False
        ActiveSheet.PivotTables("拣货单数据透视表").PivotFields("货品名称").Subtotals(1) = False
        ActiveSheet.PivotTables("拣货单数据透视表").PivotFields("颜色:").Subtotals(1) = False
        ActiveSheet.PivotTables("拣货单数据透视表").RowAxisLayout xlTabularRow
        
        '添加行标签和数值字段（计数、求和）
        With ActiveSheet.PivotTables("拣货单数据透视表").PivotFields("拣货储位")
            .Orientation = xlRowField
            .Position = 1
        End With
        With ActiveSheet.PivotTables("拣货单数据透视表").PivotFields("货品名称")
            .Orientation = xlRowField
            .Position = 2
        End With
        With ActiveSheet.PivotTables("拣货单数据透视表").PivotFields("颜色:")
            .Orientation = xlRowField
            .Position = 3
        End With
        
        ActiveSheet.PivotTables("拣货单数据透视表").AddDataField ActiveSheet.PivotTables( _
            "拣货单数据透视表").PivotFields("拣货单号"), "拣货单数量", xlCount
        ActiveSheet.PivotTables("拣货单数据透视表").AddDataField ActiveSheet.PivotTables("拣货单数据透视表" _
            ).PivotFields("应拣货数量 "), "应拣货总量 ", xlSum
        
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\new" & datfile          'ActiveWorkbook.Save
        ActiveWindow.Close
        Windows(thisfile).Activate
        Worksheets("系统参数").Select
        Cells(unit_num, 3) = "成功"

    Next unit_num

    MsgBox "信息处理完毕！", vbOKOnly, "iamlaosong"
    Exit Sub
Err:
    MsgBox "错误#" & Str(Err.Number) & Err.Description & "-位置： " & row1, vbOKOnly + vbExclamation, "iamlaosong"
End Sub

生成的数据透视表如下所示：