求助：把Table 1的数据，转换成表2的式样，请老师帮忙？谢谢！

jiali0208

求助：把Table1的数据，转换成表2的式样，请老师帮忙？谢谢！

jiali0208

请求各位老师和大侠帮助下！

sam-wang

jiali0208 发表于 2022-5-23 22:06
请求各位老师和大侠帮助下！

請測試看看，謝謝

Sub test()
Dim Arr, xD, Brr(1 To 30, 1 To 6), T0$, T, n%, s&, s2&, R&, ky, i&, j%
Application.DisplayAlerts = False
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(Arr)
    T = Arr(i, 1)
    If InStr(T, "客") Then: s = 0: T0 = Split(T, "：")(1): GoTo 95
    If UCase(Left(Arr(i, 2), 1)) = "Z" Then
        n = n + 1: s = s + 1
        Brr(n, 1) = T0: Brr(n, 2) = Brr(n, 2) + s & " EA type"
        Brr(n, 3) = Arr(i, 3): Brr(n, 4) = Arr(i, 4)
        Brr(n, 5) = Arr(i, 6): Brr(n, 6) = Arr(i, 10)
        xD(T0) = Brr(n, 2)
    End If
95: Next
s = 0
For i = 1 To n
    Brr(i, 2) = xD(Brr(i, 1))
    s = Brr(i, 5) + s: s2 = Brr(i, 6) + s2
Next
xD.RemoveAll
With Sheet2
    R = .[b65536].End(3).Row
    If R > 4 Then .Range("b5:g" & R).Delete
    .[b5].Resize(n, 6) = Brr
    For j = 2 To 1 Step -1
        For i = 1 To n
            T = Brr(i, j)
            If xD.Exists(T) Then
                Set xD(T) = Union(xD(T), .Cells(i + 4, j + 1))
            Else
                Set xD(T) = .Cells(i + 4, j + 1)
            End If
        Next
        For Each ky In xD.keys
            xD(ky).Merge
        Next
        xD.RemoveAll: T = ""
    Next
    .[d3] = "共" & n & " EA type"
    .[f3] = s: .[g3] = s2
End With
Application.DisplayAlerts = True
End Sub

jiali0208

sam-wang 发表于 2022-5-24 13:09
請測試看看，謝謝

Sub test()

收到，谢谢老师，非常感谢！