返回列表 上一主題 發帖

[發問] 找出重覆資料

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
1# 跳轉到 »
發表於 2021-3-5 03:09 | 顯示全部帖子
本帖最後由 軒云熊 於 2021-3-5 03:23 編輯

回復 3# mdr0465

有空幫我試試看　是不是你要的結果　感謝　　有一個問題　就是資料太多　會等很久．．．因為迴圈太多了而且是直接輸入到儲存格　看看有沒有大大可以幫忙　　

0305.rar (22.53 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
2#
發表於 2021-3-5 22:03 | 顯示全部帖子
本帖最後由 軒云熊 於 2021-3-5 22:04 編輯

回復 7# mdr0465

建議你用  ML089版大 的修改 剛才測試 資料過多的話 不會太慢...而且邏輯很清楚
  1. Sub test()

  3.     Dim D As Object, R, x, k

  5.     Application.ScreenUpdating = False
  6.     [A2:A10000].EntireRow.Interior.ColorIndex = xlNone
  7.     [H2:J10000].Clear

  9.     Set D = CreateObject("Scripting.Dictionary")
  10.     For Each R In Range("D1").CurrentRegion.Columns(4).Cells
  11.         R.Interior.ColorIndex = xlNone
  12.         If Not D.Exists(R.Value) Then
  13.             Set D(R.Value) = R
  14.         Else
  15.             Set D(R.Value) = Union(D(R.Value), R)
  16.         End If
  17.     Next
  18.     [H1] = "電話重覆儲存格位置"
  19.     [I1] = "對應場的名稱"
  20.     For Each R In D.KEYS
  21.         If D(R).Cells.Count > 1 Then
  22.             D(R).EntireRow.Interior.ColorIndex = 6
  23.             For Each x In D(R)
  24.                 x位置 = ""
  25.                 x場地 = ""
  26.                 For Each k In D(R)
  27.                     If x.Address <> k.Address Then
  28.                         x位置 = x位置 & "," & k.Address(0, 0)
  29.                         x場地 = x場地 & "," & k.Offset(0, -3)
  30.                     End If
  31.                 Next

  33.                 x.Offset(0, 2) = "Y"

  35.                 x.Offset(0, 4) = Mid(x位置, 2, 99)
  36.                 x.Offset(0, 5) = Mid(x場地, 2, 99)
  37.             Next
  38.         End If
  39.     Next
  40.     Application.ScreenUpdating = True
  41. End Sub
複製代碼

TOP

        靜思自在 : 改變自己是自救，影響別人是救人。
返回列表 上一主題