20170731xlVba根据数据表和模板表生成新表

Public Sub SplitData()

    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim NewSht As Worksheet

    Dim arr As Variant
    Dim Brr()

    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("总")

    With Sht
        endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A3:L" & endrow)
        arr = Rng.Value

        For J = 6 To UBound(arr, 2)
            ReDim Brr(1 To 6, 1 To 1)
            Index = 0
            mysum = 0
            Set NewSht = CopySheet("模板", arr(1, J))
            For i = LBound(arr) + 1 To UBound(arr)
                If Len(arr(i, J)) > 0 Then
                    If arr(i, J) > 0 Then
                        Index = Index + 1

                        ReDim Preserve Brr(1 To 6, 1 To Index)

                        Brr(1, Index) = Index
                        Brr(2, Index) = arr(i, 2)    '品名
                        Brr(3, Index) = arr(i, 3)    '单位
                        Brr(4, Index) = arr(i, 5)    '单价
                        Brr(5, Index) = arr(i, J)    '数量
                        Brr(6, Index) = arr(i, 5) * arr(i, J)    '数量
                        mysum = mysum + Brr(6, Index)
                    End If
                End If
            Next i

            With NewSht

                .Range("E3").Value = arr(1, J)

                Set Rng = .Range("A4")
                Set Rng = Rng.Resize(UBound(Brr, 2), UBound(Brr))
                Rng.Value = Application.WorksheetFunction.Transpose(Brr)

                SetBorders Rng

                Set Rng = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
                Rng.Value = "合计"
                Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0)
                Rng.Value = mysum

                Set Rng = .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
                Rng.Value = "注：一式三联，第三联为供应商所有，其它联为客户所有。"
                Rng.HorizontalAlignment = xlLeft

            End With

        Next J

    End With

    Set Wb = Nothing
    Set Sht = Nothing
    Set NewSht = Nothing

End Sub
Sub SetBorders(ByVal Rng As Range)
    With Rng.Borders
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub


Public Function CopySheet(ByVal Model As String, ByVal NewName As String) As Worksheet

    Application.DisplayAlerts = False

    Dim Wb As Workbook
    Dim ModelSht As Worksheet
    Dim NewSht As Worksheet

    Set Wb = Application.ThisWorkbook
    Set ModelSht = Wb.Worksheets(Model)

    On Error Resume Next
    Wb.Worksheets(NewName).Delete
    On Error GoTo 0

    ModelSht.Copy After:=Wb.Worksheets(Wb.Worksheets.Count)
    Set NewSht = Wb.Worksheets(Wb.Worksheets.Count)
    NewSht.Name = NewName

    Application.DisplayAlerts = True

    Set CopySheet = NewSht

    Set Wb = Nothing
    Set NewSht = Nothing
    Set ModelSht = Nothing

End Function