av8d

回復 10# 准提部林


    非常感謝版主抽空幫助解題，
   後面發現姓名有機會重複，我改了雙主鍵  T = Arr(i, 2) & Arr(i, 3)
   就排除了，得到所需要的表格內容，可說是受益良多。

准提部林

回復 11# av8d


若要連接文字, 最好養成習慣加"分隔符號"
例:
A  AA...."A" & "AA" = "AAA"
AA  A..."AA" & "A" = "AAA"
兩者無法分辨, 視為相同,
改成:
A  AA...."A" & "|" & "AA" = "A|AA"
AA  A..."AA" & "|" & "A" = "AA|A"
即可清楚分辨差異, 雖然遇到機會不多, 但還是謹慎~~

av8d

回復 12# 准提部林

    謝謝版主大大，剛好也讓我明白了為什麼samwang前輩所使用的
    Arr(i, 1) & "|" & Sheets(sh).Name 中的 "|" 原因了，
    嚴謹的程式碼真的很重要，也是我一直缺少且必須不斷學習的！

av8d

回復 12# 准提部林

准大您好，
關於http://forum.twbts.com/viewthread.php?tid=21077
3樓准大發表的文章中要如何達成U>0及U<0在我的問題中呢？
U>0  重複時的第一筆資料
U<0  重複第二筆資料以上

目前能改寫的部分
xD(T) = 1  去除重複
xD(T) = 2  重複第二筆資料
xD(T) = 3  重複第三筆資料
xD(T) >1  重複第二筆資料
xD(T) >2  重複第三筆資料

不知有沒有辦法改寫成重複時的所有資料，也就是U>0和U<0
詳如附件，總表為答案，謝謝准大


總表重複3.rar (26.42 KB)

下載次數: 6

2022-1-12 16:11

av8d

回復 12# 准提部林

    版主您好，目前有解開一半了，

    U<0  重複第二筆資料以上，已透過xD(T) <> 1解開了，
    只剩下U>0  重複時的第一筆資料，還沒想出來了，繼續努力中。

samwang

回復 15# av8d
請測試看看，謝謝
Sub test()
Dim Arr, xD, Brr(1 To 1000, 1 To 4), i&, n%, sh%, j%, T$
Set xD = CreateObject("Scripting.Dictionary")
For sh = 2 To Sheets.Count
    With Sheets(sh)
        Arr = .[a1].CurrentRegion
        For i = 2 To UBound(Arr)
            T = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3): xD(T) = xD(T) + 1
        Next
    End With
Next
For sh = 2 To Sheets.Count
    With Sheets(sh)
        Arr = .[a1].CurrentRegion
        For i = 2 To UBound(Arr)
            T = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3)
            If xD(T) > 1 Then
                n = n + 1: For j = 1 To 3: Brr(n, j) = Arr(i, j): Next
                Brr(n, 4) = Sheets(sh).Name
            End If
        Next
    End With
Next
If n > 0 Then
    With Sheets("總表")
        .[a1].CurrentRegion.Offset(1) = ""
        .Range("a2").Resize(n, 4) = Brr
    End With
End If
End Sub

准提部林

建議用16樓samwang 大的方法...用兩次迴圈~~

以下兩種代碼僅供參考, 難以理解, 不想多做解釋了!
Sub TEST_A1()
Dim Arr, Brr, Crr, xD, S As Worksheet, SN$, T$, U&, i&, j%, k&, N&, P%
Set xD = CreateObject("Scripting.Dictionary")
ReDim Brr(1 To 30000, 1 To 4): Crr = Brr
For Each S In Sheets
    Arr = S.[a1].CurrentRegion: SN = S.Name
    If Not SN Like "*#日" Then GoTo x01
    For i = 2 To UBound(Arr)
        T = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3)
        k = k + 1: Crr(k, 4) = SN: U = xD(T): P = 0
        If U > 0 Then N = N + 1: P = 1
        For j = 1 To 4
            If j < 4 Then Crr(k, j) = Arr(i, j)
            If U > 0 Then Brr(N, j) = Crr(U, j): xD(T) = -1
            If U < 0 Or P = 1 Then Brr(N + 1, j) = Crr(k, j)
        Next j
        If xD(T) = 0 Then xD(T) = k Else N = N + 1
i01: Next i
x01: Next
With Sheets("總表")
    .[a1].CurrentRegion.Offset(1).ClearContents
    If N > 0 Then .[a2].Resize(N, 4) = Brr
End With
End Sub

'============================
Sub TEST_A2()
Dim Arr, Brr, Crr, xD, S As Worksheet, SN$, T$, i&, j%, k&, N&
Set xD = CreateObject("Scripting.Dictionary")
ReDim Brr(1 To 30000, 1 To 4): Crr = Brr
For Each S In Sheets
    Arr = S.[a1].CurrentRegion: SN = S.Name
    If Not SN Like "*#日" Then GoTo x01
    For i = 2 To UBound(Arr)
        k = k + 1: Crr(k, 4) = SN: T = "": U = 0
        For j = 1 To 3
            T = T & "|" & Arr(i, j)
            Crr(k, j) = Arr(i, j)
        Next j
        If xD(T) = 0 Then xD(T) = k: GoTo i01
        If xD(T) > 0 Then U = xD(T): N = N + 1: xD(T) = -1
        For j = 1 To 4
            If U > 0 Then Brr(N, j) = Crr(U, j)
            Brr(N + 1, j) = Crr(k, j)
        Next
        N = N + 1
i01: Next i
x01: Next
With Sheets("總表")
    .[a1].CurrentRegion.Offset(1).ClearContents
    If N > 0 Then .[a2].Resize(N, 4) = Brr
End With
End Sub


'======================================

av8d

回復 17# 准提部林


    samwang大，萬分感謝，三個願望一次滿足。

   1.不知為何要存兩次主鍵給字典？可能我理解有誤
   2.RemoveAll要加在哪可以讓工作表各自獨立作業

av8d

回復 17# 准提部林


    我回錯人了，抱歉，版主謝謝你，這兩個我會仔細研究了，受益良多。

准提部林

回復 19# av8d

兩個迴圈, 第一次寫入字典, 第二次讀取字典, 也可參考如下:
Sub TEST_A3()
Dim Arr, Brr(1 To 3000, 1 To 5), Crr, xD, T$, i&, j%, k&, N&, x%
Set xD = CreateObject("Scripting.Dictionary")
For x = 2 To Sheets.Count
    Arr = Sheets(x).[a1].CurrentRegion
    For i = 2 To UBound(Arr)
        T = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3) '連接字串
        xD(T) = xD(T) + 1 '使用字典累計出現次數
        k = k + 1:  Brr(k, 4) = Sheets(x).Name: Brr(k, 5) = T '暫時將各工作表內容(含工作表名稱及T連接文字)放入Brr
        For j = 1 To 3: Brr(k, j) = Arr(i, j): Next
    Next i
Next
For i = 1 To k '以Brr跑迴圈(此時不須再逐一讀取工作表, 同時減少文字連接動作, 加快速度)
    If xD(Brr(i, 5)) > 1 Then N = N + 1 Else GoTo i01
    For j = 1 To 4: Brr(N, j) = Brr(i, j): Next '重覆的由上而下再次寫入Brr
i01: Next i
With Sheets("總表")
    .[a1].CurrentRegion.Offset(1).ClearContents
    If N > 0 Then .[a2].Resize(N, 4) = Brr
End With
End Sub