­«½Æ­È¤À²Õ

eric7765

½Ð°Ý«e½ú­Ì
AÄæ ¬ù¦³ 3000µ§¸ê®Æ ¦p¦ó¥Î¤½¦¡©Î¬OVBAªº¤è¦¡  ¦bEÄæÅã¥Ü­«½Æ­È  ¨Ã¦b«á­± Åã¬O¨º¨Ç²Õ§O­«½Æ

¤U¸ü (33.47 KB)

2020-4-4 15:27

­«½Æ­È.zip (6.35 KB)

¤U¸ü¦¸¼Æ: 24

2020-4-4 15:28

­ã´£³¡ªL

Sub TEST()
Dim Arr, Brr, xD, i&, T1$, T2$, N1&, N2&, R&, C&
ActiveSheet.UsedRange.Offset(, 4).ClearContents
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([B1], [A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 200)
Brr(1, 1) = "­«½Æ­È"
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1):  T2 = Arr(i, 2)
    If T1 = "" Or T2 = "" Then GoTo 101
    R = xD(T1):  C = xD(T2)
    If R = 0 Then N1 = N1 + 1: R = N1: xD(T1) = N1
    If C = 0 Then N2 = N2 + 1: C = N2: xD(T2) = N2
    Brr(R + 1, 1) = T1:  Brr(1, C + 1) = T2
    Brr(R + 1, C + 1) = T2
101: Next i
If N1 = 0 Or N2 = 0 Then Exit Sub
[E1].Resize(R + 1, C + 1) = Brr
End Sub


================================

hcm19522

(¿é¤J½s¸¹12000) googleºô§}:https://hcm19522.blogspot.com/

n7822123

¦^´_ 1# eric7765


·Ç¤jªºµ{¦¡¦n¹³§â¨S¦³­«½Æªº³¡¤À¡A¤]¤@°_¦C¥X¨Ó¤F

¤À¨É¤@¤U§Úªº¼gªk

1.¥¿±`¼gªk~2­ÓFor°j°é

Sub L2()
Dim Arr, Brr, K, D As Object
Set D = CreateObject("Scripting.Dictionary")
[E1].CurrentRegion.ClearContents
Arr = Range([B1], [A65536].End(xlUp))
For R = 2 To UBound(Arr)
  ½s$ = Arr(R, 1)
  D(½s) = D(½s) & "," & Arr(R, 2)
Next
'===========
Brr = Array("­«½Æ­È", "A", "B", "C", "D", "E", "F", "G")
[E1].Resize(1, UBound(Brr) + 1) = Brr
ReDim Brr(1 To D.Count, 1 To UBound(Brr))
For Each Key In D.keys
  K = Split(D(Key), ",")
  If UBound(K) > 1 Then
    Ro% = Ro% + 1
    Brr(Ro, 1) = Key
    For C = 1 To UBound(K)  'ASC("A")=65
      Brr(Ro, Asc(UCase(K(C))) - 63) = K(C)
    Next
  End If
Next
[E2].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End Sub


2.¤ñ¸ûÃøÀ´ªº¼gªk~1­ÓFor°j°é
   (¹ê´ú°õ¦æ³t«×¨S¦³¤ñ¸û§Ö..........)


Sub L1()
Dim Arr, Brr, D As Object
Set D = CreateObject("Scripting.Dictionary")
[E1].CurrentRegion.ClearContents
Arr = Range([B1], [A65536].End(xlUp))
Brr = Array("­«½Æ­È", "A", "B", "C", "D", "E", "F", "G")
[E1].Resize(1, UBound(Brr) + 1) = Brr
ReDim Brr(1 To UBound(Arr), 1 To UBound(Brr))
For R = 2 To UBound(Arr)
  ½s$ = Arr(R, 1): ²Õ$ = D(½s)
  If ²Õ = "" Then
    D(½s) = Arr(R, 2)
  ElseIf Val(²Õ) = 0 Then  'ASC("A")=65
    Ro% = Ro% + 1: Brr(Ro, 1) = ½s: D(½s) = Ro
    Brr(Ro, Asc(UCase(²Õ)) - 63) = ²Õ
    Brr(Ro, Asc(UCase(Arr(R, 2))) - 63) = Arr(R, 2)
  ElseIf Val(²Õ) >= 1 Then
    Brr(Val(²Õ), Asc(UCase(Arr(R, 2))) - 63) = Arr(R, 2)
  End If
Next
[E2].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End Sub

­ã´£³¡ªL

¨Sª`·N­n"­«ÂÐ"ªº:
Sub TEST()
Dim Arr, Brr, xD, i&, T1$, T2$, N1&, N2&, R&, C&, U&
ActiveSheet.UsedRange.Offset(, 4).ClearContents
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([B1], [A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 200)
Brr(1, 1) = "­«½Æ­È"
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1):  T2 = Arr(i, 2)
    If T1 = "" Or T2 = "" Then GoTo 101
    C = xD(T2)
    If C = 0 Then N2 = N2 + 1: C = N2: xD(T2) = C: Brr(1, C + 1) = T2
    U = xD(T1 & "/")
    If U = 0 Then xD(T1 & "/") = C: GoTo 101
    R = xD(T1)
    If R = 0 Then N1 = N1 + 1: R = N1: xD(T1) = R: Brr(R + 1, 1) = T1
    Brr(R + 1, C + 1) = T2
    If U > 0 Then Brr(R + 1, U + 1) = Brr(1, U + 1): U = -99
101: Next i
If N1 = 0 Or N2 = 0 Then Exit Sub
With [E1].Resize(N1 + 1, N2 + 1)
     .Value = Brr
     .Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlYes
End With
End Sub


'==========================

GBKEE

¤£¥Î¦r¨åª«¥óªº¼gªk

1. Option Explicit
   
2. Sub Ex_­«½Æ­È¤À²Õ()
   
3.     Dim Rng As Range, Ar(), Arr(), F As Boolean
   
4.     Set Rng = Range("A1").CurrentRegion     '**Set (³]¥ßª«¥ó):½s¸¹²Õ§O¸ê®ÆÄæ¦ì©Ò¦bªº¦ì¸m
   
5.     Application.ScreenUpdating = False         '** ¦pªG¶}±Ò¿Ã¹õ§ó·s¡A«h¥»ÄݩʭȬ° True¡C ¥iŪ¼gªº Boolean
   
6.     With Cells(1, Columns.Count - 1)                '**With :³¯­z¦¡·|°w¹ï°õ¦æ¤@¨t¦C³¯­z¦¡ªº³æ¤@ª«¥ó
   
7.         .CurrentRegion.Clear                                   '**CurrentRegion¶Ç¦^Rangeª«¥ó¡A¥Nªí¥Ø«eªº°Ï°ì¡C ¥Ø«e°Ï°ì¬O«ü¥H¥ô·NªÅ¥Õ¦C¤ÎªÅ¥ÕÄ檺²Õ¦X¬°Ãä¬Éªº½d³ò
   
8.         Rng.Columns(2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1), Unique:=True                       '**AdvancedFilte:¶i¶¥¿z¿ï (²Õ§O¤£­«½Æ)
   
9.         .Range("A:A").Sort Key1:=.Cells(1), Header:=xlYes, Order1:=xlAscending   '**Sort ±Æ§Ç(²Õ§O)
   
10.         Arr = .Range("A:A").SpecialCells(xlCellTypeConstants).Value                          '** ²Õ§O (±Æ§Ç«á)¸m¤J°}¦C¤¤
    
11.         Ar = Arr
    
12.         Ar(1, 1) = "½s¸¹"
    
13.         Rng.Copy .Cells                   '**½Æ»s½s¸¹²Õ§O¸ê®Æ
    
14.        .CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Key2:=.Cells(1, 2), Header:=xlYes, Order2:=xlAscending   '**Sort ±Æ§Ç(1½s¸¹2èʧO)
    
15.         Set Rng = .Range("A2")   '**Set (³]¥ßª«¥ó): ½Æ»s½s¸¹²Õ§O¸ê®Æ«áªº.Range("A2")¦ì¸m
    
16.     End With
    
17.    '******­«½Æ­È¤À²Õ ****
    
18.      F = True            '**FÅܼƬ°¥¬ªL­È(Boolean) : §P©w:½s¸¹¤À²Õ¬O§_­«½Æ
    
19.    Do While Rng.Range("A2") <> ""     '**While °j°é¹B¦æªº±ø¥ó
    
20.             With Rng
    
21.                 If .Range("a1") = .Range("a2") And (.Range("b1") <> .Range("b2") And .Range("b1") <> "" And .Range("b2") <> "") Then
    
22.                      ' Range("a1") = .Range("a2")**¦P¤@½s¸¹** : And (.Range("b1") <> .Range("b2")**¤£¦PèʧO** And .Range("b1") <> "" And .Range("b2") <> ""
    
23.                     If F Then         '**¤£­«½Æ (½s¸¹¤À²Õ)
    
24.                         F = False    '**­«½Æ (½s¸¹¤À²Õ)
    
25.                         ReDim Preserve Ar(1 To UBound(Ar), 1 To UBound(Ar, 2) + 1)  '** PreserveÃöÁä¦r, ¥u¯àÅܧó³Ì«á¤@­Óºû«×ªº¤j¤p, ¦Ó¥B¤´µM«O¯d°}¦Cªº¤º®e
    
26.                         Ar(1, UBound(Ar, 2)) = .Value                                                                 '** ¸m¤J½s¸¹
    
27.                         Ar(Application.Match(.Range("b1"), Arr, 0), UBound(Ar, 2)) = .Range("b1")
    
28.                         '**Application.Match(.Range("b1"), Arr, 0)  '** ©ó²Õ§O(±Æ§Ç«á)°}¦C¤¤´M§ä ¸Ó²Õ§Oªº¦ì¸m
    
29.                     End If
    
30.                      Ar(Application.Match(.Range("b2"), Arr, 0), UBound(Ar, 2)) = .Range("b2")
    
31.                   End If
    
32.             End With
    
33.             If Rng <> Rng.Range("A2") Then F = True    '**¤£¦Pªº½s¸¹®É,FÅܼƬ°:¤£­«½Æ (½s¸¹¤À²Õ)
    
34.             Set Rng = Rng.Range("A2")                               '**Set (³]¥ßª«¥ó) ¤U¤@­Ó½s¸¹¦ì¸m
    
35.     Loop
    
36.    With Range("f1")
    
37.         .CurrentRegion.Clear
    
38.         .Resize(UBound(Ar, 2), UBound(Ar, 1)) = Application.Transpose(Ar)    '**Application.Transpose(Ar): ½Âà(Ar),Ar¬°¤Gºû°}¦C
    
39.     End With
    
40.     Cells(1, Columns.Count - 1).CurrentRegion.Clear
    
41.     Application.ScreenUpdating = True
    
42. End Sub

½Æ»s¥N½X

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C.¦r¨å.ÅÞ¿è­È¹Bºâ»P¹B¥Îªì©l­È,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú­Ì«ü±Ð

°õ¦æ«e:

¤U¸ü (103.72 KB)

2023-11-10 15:50

°õ¦æµ²ªG:

¤U¸ü (109.51 KB)

2023-11-10 15:51

Option Explicit
Sub TEST_1()
Dim Brr, Crr, Z, i&, R&, C%, Y&, X%, T$, T1$, T2$, V1%, V2%, Tr&
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([B2], [A65536].End(xlUp))
ReDim Crr(100, 100)
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): T2 = Brr(i, 2): T = Z(T1 & "/t"): Tr = Z(T1 & "/tr")
   V1 = Z(T1 & "/r"): V2 = Z(T2 & "/c"): R = Z(T1): C = Z(T2)
   If T1 = "" Or T2 = "" Then GoTo i01
   If R = 0 Then
      Y = Y + 1
      Z(T1) = Y
      Z(T1 & "/r") = 1
      Z(T1 & "/t") = T2
      Z(T1 & "/tr") = IIf(V2 = 0, X + 1, Z(T2))
   End If
   If C = 0 Then
      X = X + 1
      Z(T2) = X: C = X
      Z(T2 & "/c") = 1
      Crr(0, X) = T2
   End If
   Crr(R * -(V1 = 1), 0) = T1
   Crr(R * -(V1 = 1), C) = T2
   If T <> "" Then Crr(R, Tr) = T: Z(T1 & "/t") = ""
i01: Next
If X = 0 Or Y = 0 Then Exit Sub
Crr(0, 0) = "­«½Æ­È"
With [E10].Resize(Y + 1, X + 1)
   .Value = Crr: .Sort Key1:=.Item(1), Order1:=1, Header:=1
End With
Set Z = Nothing: Erase Brr, Crr
End Sub

singo1232001

¦^´_ 1# eric7765


    Sub test()
Set CN = CreateObject("adodb.connection"): V = Application.Version
If V >= 12 Then C = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;"
If V < 12 Then C = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;"
CN.Open C & "Data Source=" & ThisWorkbook.FullName:
With ActiveSheet: .Range("E:Z").ClearContents
q = "select distinct ²Õ§O from [" & .Name & "$A1:B] order by ²Õ§O"
ar = CN.Execute(q).getrows
.[F1].Resize(1, UBound(ar, 2) + 1) = ar
q = "select ½s¸¹ from [" & .Name & "$A1:A] group by ½s¸¹ "
.[E2].CopyFromRecordset CN.Execute(q & "having count(*) > 1 order by ½s¸¹")
.[E1] = "­«½Æ­È": w = 6
For Each Z In ar
o = "select b.²Õ§O from [" & .Name & "$E1:E] as a left join ( "
o = o & "select * from [" & .Name & "$A1:B] where ²Õ§O='" & Z & "') as b on a.­«½Æ­È = b.½s¸¹"
.Cells(2, w).CopyFromRecordset CN.Execute(o): w = w + 1
Next: End With
End Sub
123.zip (15.33 KB)

¤U¸ü¦¸¼Æ: 1

2023-11-10 23:21