- ©«¤l
- 1446
- ¥DÃD
- 40
- ºëµØ
- 0
- ¿n¤À
- 1470
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Excel 2010 & 2016
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥xÆW
- µù¥U®É¶¡
- 2020-7-15
- ³Ì«áµn¿ý
- 2024-10-21
|
¥»©«³Ì«á¥Ñ Andy2483 ©ó 2023-3-29 15:29 ½s¿è
¦^´_ 14# Hsieh
ÁÂÁ½׾Â,ÁÂÁ«e½ú
«á¾Ç½m²ß:
1.§ì¨ú¸ê®Æ¦C2¿ªº°}¦C
2.¦P¤@°}¦C«e¬q¬Oì©l¸ê®Æ,«á¬q©ñµ²ªG¸ê®Æ
3.¦A±N«e¬qì©l¸ê®Æ²M°£
4.¶¶±Æ§Ç±Nµ²ªG¸ê®Æ«e®¿
5.¥Î¦r¨å²£¥ÍÅܼÆ
½Ð«e½úÌ«ü±Ð
Option Explicit
Sub TEST_2()
Dim Brr, V, Y, i&, N&, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
N = Cells(Rows.Count, 1).End(3).Row
Set xR = Range([B1], Cells(N * 2, 1))
Brr = xR: Y(0) = N: Y(2) = "; "
For i = 2 To UBound(Brr) / 2
For Each V In Split(Brr(i, 1), Y(2))
If InStr(Y(3), "/" & V & "/") = 0 And V <> "" Then
Y(3) = Y(3) & "/" & V & "/": Y(1) = Y(1) + 1
If Y(V) = "" Then
Y(0) = Y(0) + 1: Y(V) = Y(0)
Brr(Y(0), 1) = V: Brr(Y(0), 2) = 1
Else
Brr(Y(V), 2) = Brr(Y(V), 2) + 1
End If
End If
Next
Y(3) = ""
Next
With [J1].Resize(UBound(Brr), 2)
.EntireColumn.ClearContents
.Value = Brr
Intersect(Rows("1:" & N), .Cells).ClearContents
.Item(1) = "°ê§O": .Item(2) = "°ê§O¼Æ(¨C®æ¤£«½Æ²Îp)"
.Sort KEY1:=.Item(1), Order1:=1, Header:=1
.EntireColumn.AutoFit
End With
MsgBox Y(1)
Set Y = Nothing: Set Brr = Nothing: Set xR = Nothing
End Sub
=========================================
¸É¥R:
§Ñ¤F¦Ò¼{¨ì°ê§O¼Æ¦pªG¤ñì¸ê®Æ¦C¦h´N·|¿ù»~,2¿³ô¼{!¦¹ªk¤£¦n
=========================================
Option Explicit
Sub TEST_3()
Dim Arr, Brr, V, Y, i&, N&, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B1], Cells(Rows.Count, 1).End(3))
Brr = xR: Y(2) = "; "
ReDim Arr(1 To 10000, 1 To 2)
For i = 2 To UBound(Brr)
For Each V In Split(Brr(i, 1), Y(2))
If InStr(Y(3), "/" & V & "/") = 0 And V <> "" Then
Y(3) = Y(3) & "/" & V & "/": Y(1) = Y(1) + 1
If Y(V) = "" Then
Y(0) = Y(0) + 1: Y(V) = Y(0)
Arr(Y(0), 1) = V: Arr(Y(0), 2) = 1
Else
Arr(Y(V), 2) = Arr(Y(V), 2) + 1
End If
End If
Next
Y(3) = ""
Next
With [J2].Resize(Y(0), 2)
.EntireColumn.ClearContents
.Value = Arr
.Item(0, 1) = "°ê§O": .Item(0, 2) = "°ê§O¼Æ(¨C®æ¤£«½Æ²Îp)"
.Sort KEY1:=.Item(1), Order1:=1, Header:=2
.EntireColumn.AutoFit
End With
MsgBox Y(1)
Set Y = Nothing: Set Brr = Nothing: Set xR = Nothing
End Sub |
|