文本的多条件分类汇总

笨鸟飞不高

行、列标题带排序的凑一个！

沧海一粟123123

参考附件内容

翁知江安

经过3小时操作。得出上图的结果

翁知江安

Sub fenlei11()
Dim i, j, k, irow, irow1, m, n, p, t, x, y, z
Dim kk  As String
Dim a As Date
a = Time
Dim arr
Dim d1 As Object
Dim d2 As Object
Dim d3 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
irow = Sheets("源").[a65536].End(xlUp).Row
arr = Sheets("源").Range("a1:c" & irow)
For i = 2 To irow
d1(arr(i, 2)) = ""
d2(arr(i, 1)) = ""
If Not d3.exists(arr(i, 2) & arr(i, 1)) Then
   d3(arr(i, 2) & arr(i, 1)) = arr(i, 3)
   Else
   d3(arr(i, 2) & arr(i, 1)) = d3(arr(i, 2) & arr(i, 1)) & "*" & arr(i, 3)
End If
Next
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "过渡"
With Sheets("过渡")

.[b1].Resize(1, d1.Count) = d1.keys
.[a2].Resize(d2.Count, 1) = Application.WorksheetFunction.Transpose(d2.keys)

For j = 2 To d1.Count + 1
   For k = 2 To d2.Count + 1
   .Cells(k, j) = d3(.Cells(1, j).Value & .Cells(k, 1).Value)
   Next
Next
.[a1].Resize(d2.Count + 1, d1.Count + 1).Sort .[a1], xlAscending, , , , , , xlYes, , , xlTopToBottom
.[b1].Resize(d2.Count + 1, d1.Count).Sort .[b1], xlAscending, , , , , , , , , xlLeftToRight
End With
Sheets("过渡").Rows(1).EntireRow.Copy Sheets("目标").[a1]
Sheets("目标").[a1] = "A"
For m = 2 To Sheets("过渡").[a65536].End(xlUp).Row
   irow1 = Sheets("目标").[a65536].End(xlUp).Row
   Sheets("过渡").Rows(m).EntireRow.Copy Sheets("目标").Cells(irow1 + 1, 1)
For n = 2 To d1.Count + 1
      x = Application.WorksheetFunction.Substitute(Sheets("目标").Cells(irow1 + 1, n), "*", "")
      y = Len(Sheets("目标").Cells(irow1 + 1, n))
      z = Len(x)
      t = y - z
        If t >= 1 Then
         kk = Sheets("目标").Cells(irow1 + 1, n)
          For p = 1 To t + 1
            Sheets("目标").Cells(irow1 + p, n) = Split(kk, "*")(p - 1)
            If Sheets("目标").Cells(irow1 + p, 1) = "" Then
              Sheets("目标").Cells(irow1 + p, 1) = Sheets("目标").Cells(irow1 + p - 1, 1)
            End If
           Next
        End If
Next
Next
Sheets("目标").[a1] = ""
Sheets("过渡").Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok"
MsgBox Time - a
End Sub

翁知江安

欢迎大家批评指正

lizhipei78

铁马1980 发表于 2024-10-15 21:35
借地儿练手JSA

大佬，厉害，代码学不懂得了

沧海一粟123123

Sub test()

Dim d As New Dictionary
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Dim arr
Dim brr()
Dim arr1(), arr2()
Dim x, y, i, j, k As Integer
Dim tem
Dim crr(1 To 9, 1 To 9)
Dim n1, n2

k = Range("a1").End(xlDown).Row
arr = Range("a2:c" & k)
ReDim brr(1 To UBound(arr), 1 To 3)
For x = 1 To UBound(arr)
    brr(x, 1) = Right(arr(x, 1), 1)
    brr(x, 2) = Right(arr(x, 2), 1)
    brr(x, 3) = arr(x, 3)
    d(brr(x, 1) & "*" & brr(x, 2)) = d(brr(x, 1) & "*" & brr(x, 2)) & "*" & brr(x, 3)
Next x
For x = 1 To UBound(arr)
    d1(arr(x, 1)) = ""
    d2(arr(x, 2)) = ""
Next x
ReDim arr1(1 To d1.Count)
ReDim arr2(1 To d2.Count)
For x = 1 To d1.Count
    arr1(x) = d1.Keys(x - 1)
Next x
For x = 1 To d2.Count
    arr2(x) = d2.Keys(x - 1)
Next x
For x = 1 To UBound(arr1) - 1
    For y = x + 1 To UBound(arr1)
        If arr1(x) > arr1(y) Then
            tem = arr1(y)
            arr1(y) = arr1(x)
            arr1(x) = tem
        End If
    Next y
Next x
For x = 1 To UBound(arr2) - 1
    For y = x + 1 To UBound(arr2)
        If arr2(x) > arr2(y) Then
            tem = arr2(y)
            arr2(y) = arr2(x)
            arr2(x) = tem
        End If
    Next y
Next x
For x = 1 To UBound(arr1)
Cells(1, x + 5) = arr1(x)
Next x
Range("e2").Resize(d2.Count) = Application.Transpose(arr2)
For x = 1 To d.Count - 1
n1 = Left(d.Keys(x - 1), 1)
n2 = Right(d.Keys(x - 1), 1)
crr(n2, n1) = Right(d.Items(x - 1), Len(d.Items(x - 1)) - 1)
Next x
Range("f2").Resize(9, 9) = crr
End Sub

铁马1980

lizhipei78 发表于 2024-11-6 22:07
大佬，厉害，代码学不懂得了

折煞我了，我会的对于您和铭佬这样的大神来说都是皮毛。