Board logo

標題: [發問] 如何取多個工作表非空白的值 [打印本頁]
作者: av8d    時間: 2022-1-7 21:02     標題: 如何取多個工作表非空白的值

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

詳如附件(下)
[attach]34581[/attach]
作者: samwang    時間: 2022-1-8 08:51

回復 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    時間: 2022-1-8 16:07

回復 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    時間: 2022-1-8 19:23

回復 3# av8d


寫得註解很清楚很好，都正確，互相學習努力成長，感謝
作者: 准提部林    時間: 2022-1-9 10:01

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    時間: 2022-1-9 14:15

回復 5# 准提部林


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

    唯獨有一小段程式碼還不懂，希望版主能解惑，我也持續在網路上尋找這段的解答。
    xD(T) = -9 ^ 9
作者: 准提部林    時間: 2022-1-9 16:07

回復 6# av8d


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

回復 7# 准提部林


   原來如此，版大的意思是讓就算再次遇到更多次重複的，也不會因為被存放到Brr中，對嗎？謝謝版大。
作者: av8d    時間: 2022-1-10 15:10

回復 5# 准提部林


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

    [attach]34584[/attach]

   
    錯誤程式碼：Brr(N, 0) = Arr(i, 1).Resize(i, 3)
作者: 准提部林    時間: 2022-1-10 15:23

回復 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
作者: av8d    時間: 2022-1-11 13:00

回復 10# 准提部林


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

回復 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    時間: 2022-1-11 14:19

回復 12# 准提部林

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

回復 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
詳如附件，總表為答案，謝謝准大


[attach]34597[/attach]
作者: av8d    時間: 2022-1-13 11:11

回復 12# 准提部林

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

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

回復 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
作者: 准提部林    時間: 2022-1-13 16:36

建議用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    時間: 2022-1-13 18:16

回復 17# 准提部林


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

   1.不知為何要存兩次主鍵給字典？可能我理解有誤
   2.RemoveAll要加在哪可以讓工作表各自獨立作業
作者: av8d    時間: 2022-1-13 20:25

回復 17# 准提部林


    我回錯人了，抱歉，版主謝謝你，這兩個我會仔細研究了，受益良多。
作者: 准提部林    時間: 2022-1-13 21:49

回復 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
作者: av8d    時間: 2022-1-14 14:19

回復 20# 准提部林

    謝謝版主抽空撰寫解題，最終我選擇了版主的TEST_A1，
    此版本可以快速添加xD.RemoveAll讓工作表分開執行，
    同時也能夠隨時更換T(關鍵詞)，可以說是非常多功能。
    目前在努力研究撰寫的原理，則TEST_A3算是最好理解的！



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)