123
返回列表 上一主題 發帖

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

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2022-1-7 21:02 | 只看該作者

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

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

詳如附件(下)
總表重複.rar (19.88 KB)
收藏 分享

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-10-30 
2#
發表於 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

TOP

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
3#
發表於 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
複製代碼

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-10-30 
4#
發表於 2022-1-8 19:23 | 只看該作者
回復 3# av8d


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

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
5#
發表於 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

TOP

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
6#
發表於 2022-1-9 14:15 | 只看該作者
回復 5# 准提部林


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

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

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
7#
發表於 2022-1-9 16:07 | 只看該作者
回復 6# av8d


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

TOP

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
8#
發表於 2022-1-9 18:49 | 只看該作者
回復 7# 准提部林


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

TOP

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
9#
發表於 2022-1-10 15:10 | 只看該作者
回復 5# 准提部林


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

    總表重複2.rar (26 KB)

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

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
10#
發表於 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

TOP

        靜思自在 : 虛空有盡．我願無窮，發願容易行願難。
123
返回列表 上一主題