返回列表 上一主題 發帖

[發問] 找出重覆資料

[發問] 找出重覆資料

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

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

謝謝

Book1.rar (31.6 KB)

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

TOP

回復 2# hcm19522


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

TOP

本帖最後由 軒云熊 於 2021-3-5 03:23 編輯

回復 3# mdr0465

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

0305.rar (22.53 KB)

TOP

回復 4# 軒云熊


    軒云熊師兄
很感謝你的幫忙,為了更配合我的需要,但當中有些地方,我嘗試自行修改程式,但始終功力有限,我都失敗了,想再次向你指教
 
1.      如果在A欄的文字不是全部一樣, 當在D欄找出有相同的時候, I欄的儲存格能否做到全部顯示出A欄相對應的儲存格文字? 比例(H欄是D6,D4, 相對應是I欄是A,B)
 
2.      而當D欄找出相同的時候, F欄相的儲存格是有”Y”字的時候, 所有相同的儲存格都會同樣顯示一樣的文字,
 
萬分感謝你

TOP

回復 5# mdr0465

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

TOP

回復 6# samwang


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

TOP

回復 7# mdr0465
  1. Sub test()

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

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

  6.     Set D = CreateObject("Scripting.Dictionary")
  7.     For Each R In Range("D1").CurrentRegion.Columns(4).Cells
  8.         R.Interior.ColorIndex = xlNone
  9.         If Not D.Exists(R.Value) Then
  10.             Set D(R.Value) = R
  11.         Else
  12.             Set D(R.Value) = Union(D(R.Value), R)
  13.         End If
  14.     Next
  15.     [H1] = "電話重覆儲存格位置"
  16.     [I1] = "對應場的名稱"
  17.     For Each R In D.KEYS
  18.         If D(R).Cells.Count > 1 Then
  19.             D(R).EntireRow.Interior.ColorIndex = 6
  20.             For Each x In D(R)
  21.                 x位置 = ""
  22.                 x場地 = ""
  23.                 For Each k In D(R)
  24.                     If x.Address <> k.Address Then
  25.                         x位置 = x位置 & "," & k.Address(0, 0)
  26.                         x場地 = x場地 & "," & k.Offset(0, -3)
  27.                     End If
  28.                 Next
  29.                 x.Offset(0, 4) = Mid(x位置, 2, 99)
  30.                 x.Offset(0, 5) = Mid(x場地, 2, 99)
  31.             Next
  32.         End If
  33.     Next
  34.     Application.ScreenUpdating = True
  35. End Sub
複製代碼
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

本帖最後由 軒云熊 於 2021-3-5 22:04 編輯

回復 7# mdr0465

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

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

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

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

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

  30.                 x.Offset(0, 4) = Mid(x位置, 2, 99)
  31.                 x.Offset(0, 5) = Mid(x場地, 2, 99)
  32.             Next
  33.         End If
  34.     Next
  35.     Application.ScreenUpdating = True
  36. End Sub
複製代碼

TOP

回復 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

        靜思自在 : 人的心地是一畦田,土地沒有播下好種子,也長不出好的果實。 -
返回列表 上一主題