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