找出重覆資料(頁 1) - Excel程式區

mdr0465 發表於 2021-3-2 14:54

找出重覆資料

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

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

謝謝

hcm19522 發表於 2021-3-2 18:59

[url]https://blog.xuite.net/hcm19522/twblog/589639767[/url]

mdr0465 發表於 2021-3-4 00:03

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114555&ptid=23055]2#[/url] [i]hcm19522[/i] [/b]

謝謝你的回覆，但可不可以用VBA解決我所有的問題，謝謝

軒云熊 發表於 2021-3-5 03:09

[i=s] 本帖最後由軒云熊於 2021-3-5 03:23 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114562&ptid=23055]3#[/url] [i]mdr0465[/i] [/b]

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

[attach]33095[/attach]

mdr0465 發表於 2021-3-5 14:38

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114574&ptid=23055]4#[/url] [i]軒云熊[/i] [/b]

軒云熊師兄
很感謝你的幫忙,為了更配合我的需要,但當中有些地方,我嘗試自行修改程式,但始終功力有限,我都失敗了,想再次向你指教

1. 如果在A欄的文字不是全部一樣, 當在D欄找出有相同的時候, I欄的儲存格能否做到全部顯示出A欄相對應的儲存格文字? 比例(H欄是D6,D4, 相對應是I欄是A,B)

2. 而當D欄找出相同的時候, F欄相的儲存格是有”Y”字的時候, 所有相同的儲存格都會同樣顯示一樣的文字,

萬分感謝你

samwang 發表於 2021-3-5 16:12

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114584&ptid=23055]5#[/url] [i]mdr0465[/i] [/b]

不太能理解您所描述的問題，可否請您直接將實際的需求附上解答而附檔上來
資料比數可以少一點
謝謝

mdr0465 發表於 2021-3-5 16:57

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114585&ptid=23055]6#[/url] [i]samwang[/i] [/b]

SAMWANG 謝謝你幫忙, 是我表達能力不好,
請看附圖,希望你會明白我的意思，謝謝

ML089 發表於 2021-3-5 19:43

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114586&ptid=23055]7#[/url] [i]mdr0465[/i] [/b][code]Sub test()

Dim D As Object, R, x, k

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

Set D = CreateObject("Scripting.Dictionary")
For Each R In Range("D1").CurrentRegion.Columns(4).Cells
      R.Interior.ColorIndex = xlNone
      If Not D.Exists(R.Value) Then
         Set D(R.Value) = R
      Else
         Set D(R.Value) = Union(D(R.Value), R)
      End If
Next
[H1] = "電話重覆儲存格位置"
[I1] = "對應場的名稱"
For Each R In D.KEYS
      If D(R).Cells.Count > 1 Then
         D(R).EntireRow.Interior.ColorIndex = 6
         For Each x In D(R)
            x位置 = ""
            x場地 = ""
            For Each k In D(R)
                  If x.Address <> k.Address Then
                     x位置 = x位置 & "," & k.Address(0, 0)
                     x場地 = x場地 & "," & k.Offset(0, -3)
                  End If
            Next
            x.Offset(0, 4) = Mid(x位置, 2, 99)
            x.Offset(0, 5) = Mid(x場地, 2, 99)
         Next
      End If
Next
Application.ScreenUpdating = True
End Sub[/code]

軒云熊 發表於 2021-3-5 22:03

[i=s] 本帖最後由軒云熊於 2021-3-5 22:04 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114586&ptid=23055]7#[/url] [i]mdr0465[/i] [/b]

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

Dim D As Object, R, x, k

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

Set D = CreateObject("Scripting.Dictionary")
For Each R In Range("D1").CurrentRegion.Columns(4).Cells
      R.Interior.ColorIndex = xlNone
      If Not D.Exists(R.Value) Then
         Set D(R.Value) = R
      Else
         Set D(R.Value) = Union(D(R.Value), R)
      End If
Next
[H1] = "電話重覆儲存格位置"
[I1] = "對應場的名稱"
For Each R In D.KEYS
      If D(R).Cells.Count > 1 Then
         D(R).EntireRow.Interior.ColorIndex = 6
         For Each x In D(R)
            x位置 = ""
            x場地 = ""
            For Each k In D(R)
                  If x.Address <> k.Address Then
                     x位置 = x位置 & "," & k.Address(0, 0)
                     x場地 = x場地 & "," & k.Offset(0, -3)
                  End If
            Next

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

            x.Offset(0, 4) = Mid(x位置, 2, 99)
            x.Offset(0, 5) = Mid(x場地, 2, 99)
         Next
      End If
Next
Application.ScreenUpdating = True
End Sub[/code]

samwang 發表於 2021-3-5 23:21

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114586&ptid=23055]7#[/url] [i]mdr0465[/i] [/b]

請測試看看，謝謝。

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

准提部林 發表於 2021-3-6 11:28

ARRAY 處理資料
RANGE-UNION填色
[attach]33103[/attach]

mdr0465 發表於 2021-3-6 23:02

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114588&ptid=23055]8#[/url] [i]ML089[/i] [/b]

ML089師兄，
真的謝謝你幫忙

mdr0465 發表於 2021-3-6 23:04

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114589&ptid=23055]9#[/url] [i]軒云熊[/i] [/b]

軒云熊師兄，
感謝你百忙中幫忙，謝謝你

mdr0465 發表於 2021-3-6 23:05

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114590&ptid=23055]10#[/url] [i]samwang[/i] [/b]

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

mdr0465 發表於 2021-3-6 23:06

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114593&ptid=23055]11#[/url] [i]准提部林[/i] [/b]

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

Andy2483 發表於 2023-5-31 16:28

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=114593&ptid=23055]11#[/url] [i]准提部林[/i] [/b]

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

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

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

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

頁: [1]

麻辣家族討論版版's Archiver

找出重覆資料