[發問] 如何取多個工作表非空白的值

av8d

工作表"總表"的號是取各工作表重複的值、期限則是工作表名稱
目前已知Worksheet.Name=工作表名稱
其餘尚在努力研究中，求解感謝！

詳如附件(下)
總表重複.rar (19.88 KB)

下載次數: 12

2022-1-7 21:01

samwang

回復 1# av8d

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

av8d

回復 2# samwang

由衷感謝前輩的幫助，我也努力研究學習中，並標示了註解，不知道是否有誤，還請大大有空再看，謝謝！

1.     Dim Arr, xD, Brr(1 To 1000, 1 To 2), i&, n%, sh% '宣告變數
   
2.     Set xD = CreateObject("Scripting.Dictionary") '設定xD為字典物件
   
3.     For sh = 2 To Sheets.Count '工作表2~工作表總數,For迴圈sh(宣告為int)
   
4.         With Sheets(sh) '進入工作表,以sh代入
   
5.             Arr = .[a1].CurrentRegion '選取a1包含鄰近的所有範圍,Arr為組數
   
6.             For i = 2 To UBound(Arr) '第2列~Arr的列上限,For迴圈i(宣告為Long)
   
7.                 If xD.Exists(Arr(i, 1)) Then '列是變動的，A欄是固定的，i代入列，判斷字典裡的key有沒有Arr(i, 1)，如果有就往下做
   
8.                     If Not xD.Exists(Arr(i, 1) & "|" & Sheets(sh).Name) Then '如果字典裡的key沒有Arr(i, 1)就存入字典裡，連同工作表名稱
   
9.                         n = n + 1: Brr(n, 1) = Arr(i, 1) '將Arr(i, 1)重複的資料存給Brr(n, 1)
   
10.                         Brr(n, 2) = Sheets(sh).Name '將Arr(i, 1)重複時的工作表名稱存入Brr(n, 2)
    
11.                     End If
    
12.                     xD(Arr(i, 1) & "|" & Sheets(sh).Name) = "" '如果字典裡的key有Arr(i, 1)就存入字典裡，連同工作表名稱
    
13.                 Else '判斷字典裡的key有沒有Arr(i, 1)，如果沒有就往下做
    
14.                     xD(Arr(i, 1)) = "" '將Arr(i, 1)存入字典裡
    
15.                 End If
    
16.             Next
    
17.         End With
    
18.         xD.RemoveAll '清空字典中的數據
    
19.     Next
    
20.     If n > 0 Then '如果有找到重複的資料往下做
    
21.         With Sheets("總表")
    
22.             .[a1].CurrentRegion.Offset(1) = "" '清空A、B欄數據，保留標題
    
23.             .Range("a2").Resize(n, 2) = Brr '將Brr組數釋放到A、B欄
    
24.         End With
    
25.     End If

複製代碼

samwang

回復 3# av8d


寫得註解很清楚很好，都正確，互相學習努力成長，感謝

准提部林

Sub 巨集1()
Dim Arr, Brr(1 To 1000, 1), xD, S As Worksheet, SN$, i&, T$, N&
Set xD = CreateObject("Scripting.Dictionary")
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):  xD(T) = xD(T) + 1
        If xD(T) = 2 Then N = N + 1: Brr(N, 0) = T: Brr(N, 1) = SN: xD(T) = -9 ^ 9
    Next i
    xD.RemoveAll
x01: Next
With Sheets("總表")
    .[a1].CurrentRegion.Offset(1).ClearContents
    If N > 0 Then .[a2].Resize(N, 2) = Brr
End With
End Sub

av8d

回復 5# 准提部林


    非常感謝版主抽空觀看我的問題，也讓我對程式又更深一層的理解，
    版主的答案讓我可以更快速自行更改條件，讓我對於嚴謹的程式碼有進一步的學習。

    唯獨有一小段程式碼還不懂，希望版主能解惑，我也持續在網路上尋找這段的解答。
    xD(T) = -9 ^ 9

准提部林

回復 6# av8d


-9^9=-387420489   -9的9次方,
當遇到重覆第二次時, 使字典帶值 -9^9,
偶後再遇到, 再怎麼加+1, 大約不會變正數~~

av8d

回復 7# 准提部林


   原來如此，版大的意思是讓就算再次遇到更多次重複的，也不會因為被存放到Brr中，對嗎？謝謝版大。

av8d

回復 5# 准提部林


    版主您好，我自我練習新增了進階題，改寫了一下，但是出現錯誤'424，此處需要物件。

    總表重複2.rar (26 KB)

下載次數: 6

2022-1-10 15:10

   
    錯誤程式碼：Brr(N, 0) = Arr(i, 1).Resize(i, 3)

准提部林

回復 9# av8d

resize 共能用在 range物件, array中只能跑迴圈逐一寫入:

Sub 巨集3()
Dim Arr, Brr(1 To 1000, 1 To 4), xD, S As Worksheet, SN$, i&, j%, T$, N&
Set xD = CreateObject("Scripting.Dictionary")
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, 2):  xD(T) = xD(T) + 1
        If xD(T) = 2 Then
           N = N + 1: xD(T) = -9 ^ 9
           For j = 1 To 3: Brr(N, j) = Arr(i, j): Next
           Brr(N, 4) = SN
        End If
    Next i
    xD.RemoveAll
x01: Next
With Sheets("總表")
    .[a1].CurrentRegion.Offset(1).ClearContents
    If N > 0 Then .[a2].Resize(N, 4) = Brr
End With
End Sub