Board logo

標題: 重複值分組 [打印本頁]
作者: eric7765    時間: 2020-4-4 15:28     標題: 重複值分組

請問前輩們
A欄 約有 3000筆資料 如何用公式或是VBA的方式  在E欄顯示重複值  並在後面 顯是那些組別重複
[attach]31858[/attach]
[attach]31859[/attach]
作者: 准提部林    時間: 2020-4-5 11:30

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    時間: 2020-4-5 17:12

本帖最後由 hcm19522 於 2023-11-13 11:45 編輯

(輸入編號12000) google網址:https://hcm19522.blogspot.com/
作者: n7822123    時間: 2020-4-5 21:52

本帖最後由 n7822123 於 2020-4-5 22:01 編輯

回復 1# eric7765


準大的程式好像把沒有重複的部分，也一起列出來了

分享一下我的寫法

1.正常寫法~2個For迴圈

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)
  編$ = Arr(R, 1)
  D(編) = D(編) & "," & 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.比較難懂的寫法~1個For迴圈
   (實測執行速度沒有比較快..........)


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)
  編$ = Arr(R, 1): 組$ = D(編)
  If 組 = "" Then
    D(編) = Arr(R, 2)
  ElseIf Val(組) = 0 Then  'ASC("A")=65
    Ro% = Ro% + 1: Brr(Ro, 1) = 編: D(編) = 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
作者: 准提部林    時間: 2020-4-6 16:29

沒注意要"重覆"的:
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    時間: 2020-4-14 18:30

不用字典物件的寫法
  1. Option Explicit
  2. Sub Ex_重複值分組()
  3.     Dim Rng As Range, Ar(), Arr(), F As Boolean
  4.     Set Rng = Range("A1").CurrentRegion     '**Set (設立物件):編號組別資料欄位所在的位置
  5.     Application.ScreenUpdating = False         '** 如果開啟螢幕更新，則本屬性值為 True。 可讀寫的 Boolean
  6.     With Cells(1, Columns.Count - 1)                '**With :陳述式會針對執行一系列陳述式的單一物件
  7.         .CurrentRegion.Clear                                   '**CurrentRegion傳回Range物件，代表目前的區域。 目前區域是指以任意空白列及空白欄的組合為邊界的範圍
  8.         Rng.Columns(2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1), Unique:=True                       '**AdvancedFilte:進階篩選 (組別不重複)
  9.         .Range("A:A").Sort Key1:=.Cells(1), Header:=xlYes, Order1:=xlAscending   '**Sort 排序(組別)
  10.         Arr = .Range("A:A").SpecialCells(xlCellTypeConstants).Value                          '** 組別 (排序後)置入陣列中
  11.         Ar = Arr
  12.         Ar(1, 1) = "編號"
  13.         Rng.Copy .Cells                   '**複製編號組別資料
  14.        .CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Key2:=.Cells(1, 2), Header:=xlYes, Order2:=xlAscending   '**Sort 排序(1編號2駔別)
  15.         Set Rng = .Range("A2")   '**Set (設立物件): 複製編號組別資料後的.Range("A2")位置
  16.     End With
  17.    '******重複值分組 ****
  18.      F = True            '**F變數為布林值(Boolean) : 判定:編號分組是否重複
  19.    Do While Rng.Range("A2") <> ""     '**While 迴圈運行的條件
  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")**同一編號** : And (.Range("b1") <> .Range("b2")**不同駔別** And .Range("b1") <> "" And .Range("b2") <> ""
  23.                     If F Then         '**不重複 (編號分組)
  24.                         F = False    '**重複 (編號分組)
  25.                         ReDim Preserve Ar(1 To UBound(Ar), 1 To UBound(Ar, 2) + 1)  '** Preserve關鍵字, 只能變更最後一個維度的大小, 而且仍然保留陣列的內容
  26.                         Ar(1, UBound(Ar, 2)) = .Value                                                                 '** 置入編號
  27.                         Ar(Application.Match(.Range("b1"), Arr, 0), UBound(Ar, 2)) = .Range("b1")
  28.                         '**Application.Match(.Range("b1"), Arr, 0)  '** 於組別(排序後)陣列中尋找 該組別的位置
  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    '**不同的編號時,F變數為:不重複 (編號分組)
  34.             Set Rng = Rng.Range("A2")                               '**Set (設立物件) 下一個編號位置
  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為二維陣列
  39.     End With
  40.     Cells(1, Columns.Count - 1).CurrentRegion.Clear
  41.     Application.ScreenUpdating = True
  42. End Sub
複製代碼
作者: Andy2483    時間: 2023-11-10 15:51

本帖最後由 Andy2483 於 2023-11-13 09:02 編輯

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列.字典.邏輯值運算與運用初始值,學習方案如下,請前輩們指教

執行前:
[attach]36990[/attach]

執行結果:
[attach]36991[/attach]


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    時間: 2023-11-10 23:21

回復 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 組別 from [" & .Name & "$A1:B] order by 組別"
ar = CN.Execute(q).getrows
.[F1].Resize(1, UBound(ar, 2) + 1) = ar
q = "select 編號 from [" & .Name & "$A1:A] group by 編號 "
.[E2].CopyFromRecordset CN.Execute(q & "having count(*) > 1 order by 編號")
.[E1] = "重複值": w = 6
For Each Z In ar
o = "select b.組別 from [" & .Name & "$E1:E] as a left join ( "
o = o & "select * from [" & .Name & "$A1:B] where 組別='" & Z & "') as b on a.重複值 = b.編號"
.Cells(2, w).CopyFromRecordset CN.Execute(o): w = w + 1
Next: End With
End Sub
[attach]36993[/attach]



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)