12
返回列表 上一主題 發帖

[發問] 找出重覆資料

mdr0465

帖子
163 
主題
45 
精華
0 
積分
246 
點名
27  
作業系統
win7 
軟體版本
ie 
閱讀權限
20 
性別
男 
註冊時間
2015-7-8 
最後登錄
2024-9-14 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2021-3-2 14:54 | 只看該作者

[發問] 找出重覆資料

各位大大,
我用有限的能力寫了一個"找出重覆資料的程式”, 但我有一些問題我未能解決,請各位幫忙

1.        在H欄,只顯示重覆的儲存格位置,而不顥示本身的儲存格位置
2.        在重覆的情況下, 比如F2格有”Y”的字,如何找出重覆的儲存格D86都可以有同樣的文字呢?
3.        在超過2個重覆的情況下,J 欄可以多重顯示A欄的名稱,

謝謝

Book1.rar (31.6 KB)

收藏 分享

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
16#
發表於 2023-5-31 16:28 | 只看該作者
回復 11# 准提部林


    謝謝論壇,謝謝前輩
後學藉此帖學習前輩的方案,方案學習心得註解如下,請前輩再指導

執行前:


執行結果:



Sub TEST_A01()
Dim Arr, xD, i&, T$, T1$, T2$, SR, S, xR As Range, xU As Range
'↑宣告變數
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD變數是 字典
With Range([J1], [A65536].End(3))
'↑以下是關於本表A~J欄儲存格的程序
     .EntireRow.Interior.ColorIndex = xlNone
     '↑令該區域全列底色是無色
     .Offset(1, 7).ClearContents
     '↑令該區域往下偏移1列,往右7欄區域儲存格清除內容
     [H1:J1] = Array("重覆位置", "重覆次數", "對應場名稱")
     '↑令[H1:J1]儲存格寫入列標題
     Arr = .Cells
     '↑令Arr變數是 二維陣列,以該區域儲存格值帶入陣列中
End With
For i = 2 To UBound(Arr)
'↑設順迴圈
    T = Arr(i, 4): T2 = Arr(i, 6)
    '↑令字串變數裝入陣列值
    xD(T) = Trim(xD(T) & " " & i)
    '↑令T變數當key,item是 自身連接空白字元,再連接i變數,所組成的新字串
    If T2 <> "" Then xD(T & "/y") = T2
    '↑如果T2變數不是空字元!就令T變數連接"/y"組成的新字串當key,
    'item是T2變數,納入xD字典中
Next i
For i = 2 To UBound(Arr)
'↑設順迴圈
    SR = Split(xD(Arr(i, 4) & ""), " ")
    '↑令SR變數是一維陣列:以陣列第4欄值提取xD字典item,
    '再以空白字元分割成為一維陣列
    If UBound(SR) <= 0 Then GoTo i01
    '↑如果SR陣列最後一個索引號<=0,就跳到標示i0位置繼續執行
    T1 = "": T2 = "": Set xR = Range("D" & i)
    '↑令T1,T2變數是 空字元,令xR變數是 D欄i列儲存格
    For Each S In SR
    '↑設逐項迴圈!令S變數是SR陣列值之一
        If Val(S) <> i Then
        '↑如果S變數轉數值後 與i變數不同
           T1 = T1 & "," & "D" & S
           '↑令T1變數是 自身連接逗號,再連接"D",最後連接S變數成新字串
           T2 = T2 & "," & Arr(S, 1)
           '↑令T2變數是 自身連接逗號,再連接S變數列第1欄Arr陣列值
        End If
    Next S
    Arr(i, 6) = xD(Arr(i, 4) & "/y")
    '↑令迴圈列第6欄Arr陣列值是 迴圈列第6欄Arr陣列值連接"/y"成的新字串,查
    '查xD字典回傳的item值
    Arr(i, 8) = Mid(T1, 2)
    '↑令迴圈列第8欄Arr陣列值是 T1變數取第2字以後的全部字串
    Arr(i, 9) = UBound(SR) + 1
    '↑令迴圈列第9欄Arr陣列值是 SR陣列最大索引號+1
    Arr(i, 10) = Mid(T2, 2)
    '↑令迴圈列第10欄Arr陣列值是 T2變數取第2字以後的全部字串
    If xU Is Nothing Then Set xU = xR Else Set xU = Union(xU, xR)
    '↑如果xU變數是空的,就令xU變數是xR變數,否則就將xR變數納入xU儲存格集裡
i01: Next i
[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
'↑令Arr陣列從[A1]開始寫入範圍儲存格中
If Not xU Is Nothing Then xU.EntireRow.Interior.ColorIndex = 6
'↑如果xU變數不是空的,就令該xU儲存格集所在的列整列底色為黃色
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

mdr0465

帖子
163 
主題
45 
精華
0 
積分
246 
點名
27  
作業系統
win7 
軟體版本
ie 
閱讀權限
20 
性別
男 
註冊時間
2015-7-8 
最後登錄
2024-9-14 
15#
發表於 2021-3-6 23:06 | 只看該作者
回復 11# 准提部林


  
准提部林師兄，
真的十分感激你的幫忙，謝謝你

TOP

mdr0465

帖子
163 
主題
45 
精華
0 
積分
246 
點名
27  
作業系統
win7 
軟體版本
ie 
閱讀權限
20 
性別
男 
註冊時間
2015-7-8 
最後登錄
2024-9-14 
14#
發表於 2021-3-6 23:05 | 只看該作者
回復 10# samwang


   
Samsung 師兄，
萬分感謝你幫忙，謝謝

TOP

mdr0465

帖子
163 
主題
45 
精華
0 
積分
246 
點名
27  
作業系統
win7 
軟體版本
ie 
閱讀權限
20 
性別
男 
註冊時間
2015-7-8 
最後登錄
2024-9-14 
13#
發表於 2021-3-6 23:04 | 只看該作者
回復 9# 軒云熊
   
軒云熊師兄，
感謝你百忙中幫忙，謝謝你

TOP

mdr0465

帖子
163 
主題
45 
精華
0 
積分
246 
點名
27  
作業系統
win7 
軟體版本
ie 
閱讀權限
20 
性別
男 
註冊時間
2015-7-8 
最後登錄
2024-9-14 
12#
發表於 2021-3-6 23:02 | 只看該作者
回復 8# ML089

ML089師兄，
真的謝謝你幫忙

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
11#
發表於 2021-3-6 11:28 | 只看該作者
ARRAY 處理資料
RANGE-UNION填色
Xl0000207.rar (52.52 KB)

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-10-30 
10#
發表於 2021-3-5 23:21 | 只看該作者
回復 7# mdr0465


請測試看看，謝謝。

Sub test()
Dim xD, Arr, Brr(), i&, Ar, a&, b$, j%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([F1], [a65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 1 To UBound(Arr)
    If xD.Exists(Arr(i, 4) & "") Then
        m = m + 1
        列 = xD(Arr(i, 4) & "")
        Brr(列, 3) = Brr(列, 3) & "_" & m
        Brr(列, 4) = Brr(列, 4) & "_" & Arr(i, 1)
    Else
        m = m + 1
        xD(Arr(i, 4) & "") = i
        Brr(m, 2) = Arr(i, 4)
        Brr(m, 3) = m
        Brr(m, 4) = Arr(i, 1)
    End If
Next

For i = 1 To UBound(Arr)
    For ib = 1 To UBound(Brr)
        pos = InStr(Brr(ib, 3), "_")
        If pos > 0 And Arr(i, 4) = Brr(ib, 2) Then
            Ar = Split(Brr(ib, 3), "_")
            For j = 0 To UBound(Ar)
                a = Split(Brr(ib, 3), "_")(j)
                b = Split(Brr(ib, 4), "_")(j)
                If i <> a Then
                    If Cells(i, 8) = "" Then
                        Cells(i, 8) = "D" & a
                        Cells(i, 9) = b
                        Rows(i).EntireRow.Interior.ColorIndex = 6
                    Else
                        Cells(i, 8) = Cells(i, 8) & "," & "D" & a
                        Cells(i, 9) = Cells(i, 9) & "," & b
                    End If
                End If
            Next
        End If
    Next
Next
End Sub

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
9#
發表於 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

ML089

帖子
2025 
主題
13 
精華
0 
積分
2053 
點名
0  
作業系統
WIN7 
軟體版本
Office2007 
閱讀權限
100 
性別
男 
來自
台北市 
註冊時間
2011-3-2 
最後登錄
2024-3-14 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
8#
發表於 2021-3-5 19:43 | 只看該作者
回復 7# mdr0465
  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
  32.                 x.Offset(0, 4) = Mid(x位置, 2, 99)
  33.                 x.Offset(0, 5) = Mid(x場地, 2, 99)
  34.             Next
  35.         End If
  36.     Next
  37.     Application.ScreenUpdating = True
  38. End Sub
複製代碼
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

        靜思自在 : 為自己找藉口的人永遠不會進步。
12
返回列表 上一主題