- ©«¤l
- 976
- ¥DÃD
- 7
- ºëµØ
- 0
- ¿n¤À
- 1018
- ÂI¦W
- 0
- §@·~¨t²Î
- Win10
- ³nÅ骩¥»
- Office 2016
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- µù¥U®É¶¡
- 2013-4-19
- ³Ì«áµn¿ý
- 2024-10-30
|
¥»©«³Ì«á¥Ñ samwang ©ó 2021-11-4 12:03 ½s¿è
¦^´_ 1# ÅÚ½³ªd
½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁ¡C
Sub ³æµ§¸ê®Æ()
Dim Arr, Brr, Crr(1 To 1, 1 To 100), xD, xD1, m%, m0%, m1%
Dim k0%, k1%, k%, ky, CMax, T$, n%, C%, C1%, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
With Sheets("¸ê®Æ")
With .Range(.[C1], .[a65536].End(xlUp))
Brr = .Value
.Sort Key1:=.Item(1), Order1:=xlAscending, _
Key2:=.Item(2), Order2:=xlAscending, Header:=xlYes
Arr = .Value
.Value = Brr
End With
End With
For i = 2 To UBound(Arr)
If Arr(i, 2) = "" Then GoTo 97
T = Arr(i, 1) & "_" & Arr(i, 2)
If Not xD.Exists(T) Then '¨úÄæ¼Æ
xD(Arr(i, 2) & "") = 1: xD(T) = ""
Else
k0 = xD(Arr(i, 2) & ""): k1 = xD1(Arr(i, 2) & "")
If k0 > k1 Then k = k0 + 1 Else k = k1 + 1
xD1(Arr(i, 2) & "") = k
End If
97: Next
For Each ky In xD.keys '¦C¥X²Ä¤@¦CªíÀY
If InStr(ky, "_") Then GoTo 98
If xD1.Exists(ky) Then
For j = 1 To xD1(ky): y = y + 1: Crr(1, y) = ky: Next
Else
y = y + 1: Crr(1, y) = ky: s = s + 1
End If
98: Next
xD1.RemoveAll
ReDim Brr(1 To UBound(Arr), 1 To y + 1)
With Sheets("§e²{ªí")
.[a1:aa100] = ""
.Range("b1").Resize(, y) = Crr
For i = 2 To UBound(Arr)
If Arr(i, 2) = "" Then GoTo 99
C = Application.WorksheetFunction.Match(Arr(i, 2), Sheets(2).Range("a1").Resize(, y + 1), 0)
If xD1.Exists(Arr(i, 1)) Then
m = xD1(Arr(i, 1))
If IsEmpty(Brr(m, C)) Then
Brr(m, C) = Arr(i, 3)
Else
If m0 = 0 Then m0 = m
If m0 <> m Then C1 = 0
If C1 > C Then C1 = C1 + 1 Else C1 = C + 1
Brr(m, C1) = Arr(i, 3)
End If
Else
n = n + 1: xD1(Arr(i, 1)) = n
Brr(n, 1) = Arr(i, 1): Brr(n, C) = Arr(i, 3)
End If
99: Next
.Range("a2").Resize(n, y + 1) = Brr
End With
End Sub |
-
-
22.PNG
(45.11 KB)
|