求助用VBA转换报表格式

pjypl1688888

求助用VBA转换报表格式，谢谢

shiruiqiang

排序录了个宏凑活一下

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("数源表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数源表为空！": End
    ar = .Range("a1:h" & r)
End With
Dim br(), arr()
ReDim arr(1 To 100000, 1 To 7)
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) = k Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                br(n, j) = ar(i, j)
            Next j
        End If
    Next i
     For i = 1 To n
        If Trim(br(i, 6)) <> "" Then
            rr = Split(br(i, 6), "＋")
            For s = 0 To UBound(rr)
                If Trim(rr(s)) <> "" Then
                    m = m + 1
                    For j = 1 To 4
                        arr(m, j) = br(i, j)
                    Next j
                    arr(m, 5) = rr(s) & br(i, 8)
                    arr(m, 6) = br(i, 7)
                End If
            Next s
        End If
    Next i
Next k
With Sheets("表一")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If r > 1 Then .Range("a2:f" & rs) = Empty
    .[a2].Resize(m, UBound(arr, 2)) = arr
    Set Rng = .[a1].CurrentRegion
    Rng.Sort Key1:=.[d1], Order1:=1, Header:=xlYes, Key2:=.[a1], Order2:=1, Header:=xlYes
    .Columns(7).Delete
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

锯切优化表.rar (41.12 KB, 下载次数: 14)

2023-2-5 15:49 上传

点击文件名下载附件

3190496160

尺寸排序没有考虑，要真正实现尺寸排序，恐怕得增加一个辅助才能真正实现，

pjypl1688888

好的，谢谢老师