返回列表 上一主題 發帖

重複值分組

重複值分組

請問前輩們
A欄 約有 3000筆資料 如何用公式或是VBA的方式  在E欄顯示重複值  並在後面 顯是那些組別重複
重複.png
2020-4-4 15:27

重複值.zip (6.35 KB)

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


================================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

隨意窩 "EXCEL迷"  blog  或 http://blog.xuite.net/hcm19522/twblog
已收集6200篇 EXCEL函數

TOP

本帖最後由 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
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

沒注意要"重覆"的:
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


'==========================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

不用字典物件的寫法
  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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 不要隨心所欲,要隨心教育自己。
返回列表 上一主題