|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 吉仔 于 2024-11-21 15:38 编辑
自己想按老师们教的代码修改了一下，但为什么实现不了想实现的“样式“工作表模板格式，请老师们帮忙看看代码哪个位置有误，导致不能生成对应想要的格式，谢谢！
Sub qs()
Dim arr, crr, d
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set ws = ThisWorkbook
Set sh = ws.Sheets("明细")
For Each sht In Sheets
If InStr("明细|样式", sht.Name) = 0 Then sht.Delete
Next
arr = sh.UsedRange
For i = 4 To UBound(arr)
s = arr(i, 10)
If Val(arr(i, 8)) Then
d(s) = ""
End If
Next
b = [{1,4,2,3,5,6,7,8,9}]
For Each k In d.Keys
ws.Sheets("样式").Copy After:=ws.Sheets(ws.Sheets.Count)
Set sht = ws.Sheets(ws.Sheets.Count)
sht.Name = arr(Application.Match(k, Application.Index(arr, 0, 10), 0), 10)
ReDim crr(1 To 800, 1 To 9)
m = 0
With sht
.[c2] = k:
For i = 4 To UBound(arr)
If arr(i, 5) = k Then
m = m + 1
crr(m, 1) = arr(i, 1)
For j = 2 To UBound(bb)
crr(m, j) = arr(i, b(j))
Next
End If
Next
If n > 0 Then
.[a4].Resize(800, 800).Clear
.[a4].Resize(m, 9) = crr
End If
End With
Call 明细再拆分(sht)
Next
sh.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "共用时：" & Format(Timer - tm) & "秒！"
End Sub
Sub 明细再拆分(sht)
Dim arr, rng As Range, headers As Range, d, j&
Set d = CreateObject("scripting.dictionary")
Set rng = sht.Range("d2").CurrentRegion
Set headers = rng.rows("1:3")
arr = rng.Value
For i = 4 To UBound(arr)
If arr(i, 2) <> "" Then
If Not d.exists(arr(i, 9)) Then
d(arr(i, 9)) = i
Else
d(arr(i, 9)) = d(arr(i, 9)) & " " & i
End If
End If
Next
Dim rows, row, brr, crr(), n&, lastRng As Range, col, key
Set lastRng = rng.Cells(1).Offset(rng.rows.Count - 1)
For Each key In d
n = 0: rows = Split(d(key))
ReDim crr(1 To UBound(rows) + 2, 1 To UBound(arr, 2))
For Each row In rows
n = n + 1
brr = Application.Index(arr, row)
For j = 1 To UBound(brr)
crr(n, j) = brr(j)
Next
Next
crr(n + 1, 5) = "累计金额"
For Each col In Array(6, 7, 8)
crr(n + 1, col) = "=SUM(R[-" & n & "]C[0])"
Next
Set lastRng = lastRng.Offset(6, 0)
headers.Copy lastRng
lastRng.Offset(1, 6) = key
With lastRng.Offset(3, 0).Resize(UBound(crr), UBound(crr, 2))
.Value = crr
.Borders.LineStyle = xlContinuous
End With
Set lastRng = lastRng.Offset(lastRng.CurrentRegion.rows.Count - 1)
Next
rng.Cells(1).Resize(rng.rows.Count + 5, 3).EntireRow.Delete
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-11-20 16:04
楼主
