返回列表 上一主題 發帖

重複值分組

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 不怕事多，只怕多事。
返回列表 上一主題