|
Sub 按钮2_单击()
Set d = CreateObject("scripting.dictionary")
Set dnm = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For j = Sheets.Count To 2 Step -1 '此循环直接删除原生成表,重新写入生成工作表
Sheets(j).Delete '删除生成表
Next j
'===============读取原表数据========================
arr = Sheets("记录").UsedRange
For j = 3 To UBound(arr) '读取记录循环
brr = Split("、" & arr(j, 2), "、")
For i = 1 To UBound(brr)
If Len(brr(i)) > 0 Then
If d.exists(brr(i)) Then
Set d(brr(i)) = Union(d(brr(i)), Cells(j, 1).Resize(1, 7))
Else
Set d(brr(i)) = Union([a1:g2], Cells(j, 1).Resize(1, 7))
End If
End If
Next i
Next j
'===============写入数据生成工作表========================
arr = d.keys
Call sort_arr(arr)
For Each k In arr 'd.keys '拆分写入循环
If Not dnm.exists(k) Then '拆分写入表二循环
Sheets.Add after:=Sheets(1)
Sheets(2).Name = k
End If
With Sheets(k) '拆分写入工作表程序循环
d(k).Copy .[a1]
r = .Cells(Rows.Count, 1).End(3).Row
.Range("a2:g" & r + 1).Borders.LineStyle = xlContinuous '表头删除画线
.Range("b3:b" & r).Value = k
.Cells(r + 1, 1).Resize(1, 2).Merge '合计放在第2列最后
.Cells(r + 1, 1) = "合计"
.Range("f2") = "金额"
'.Cells(r + 1, 4) = WorksheetFunction.Sum(.Range("d3:d" & r)) '计算第3列合计
.Cells(r + 1, 5) = WorksheetFunction.Sum(.Range("e3:e" & r)) '计算第5列合计
.Cells(r + 1, 6) = WorksheetFunction.Sum(.Range("F3:F" & r)) '计算第6列合计
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
' .UsedRange.Borders.LineStyle = xlContinuous '不要
.Columns(7).Delete '总共7列
'===============拆分表行列设置=======================
.UsedRange.RowHeight = 25 '拆分表所有行设置
.Rows(1).RowHeight = 31.5 '拆分表第1行行设置
.Rows(2).RowHeight = 24 '拆分表第2行行设置
.Rows(3).RowHeight = 22 '拆分表第3行行设置
.Columns("a:b").ColumnWidth = 6.5 '拆分表a:b列设置
.Columns(3).ColumnWidth = 40.63 '第3列
.Columns(4).ColumnWidth = 8.25 '第4列
.Columns(5).ColumnWidth = 7 '第5列
.Columns(6).ColumnWidth = 7 '第6列
With .PageSetup '拆分表页面设置
.LeftMargin = Application.InchesToPoints(0.884251968503937) '左边距2.2厘米,边距2.5厘米(0.984251968503937)
.RightMargin = Application.InchesToPoints(0.690551181102362) '左边距1.8厘米
.TopMargin = Application.InchesToPoints(0.984251968503937) '上边距2.5厘米
.BottomMargin = Application.InchesToPoints(0.590551181102362) '下边距1.5厘米
.HeaderMargin = Application.InchesToPoints(0.511811023622047) '页眉1.3厘米。(0.393700787401575)1.厘米
.FooterMargin = Application.InchesToPoints(0.275590551181102) '页脚0.7厘米。(0.118110236220472)0.3厘米
End With
With .Range("F1") '拆分表单元格格式设置
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter '靠右
.VerticalAlignment = xlBottom '靠下
.ReadingOrder = xlContext
End With
End With
Next k
Application.ScreenUpdating = True
End Sub
Sub sort_arr(arr)
For j = LBound(arr) To UBound(arr)
For i = j + 1 To UBound(arr)
If StrComp(arr(j), arr(i), 1) = -1 Then
tm = arr(j)
arr(j) = arr(i)
arr(i) = tm
End If
Next i
Next j
End Sub
|
评分
-
6
查看全部评分
-
|