返回列表 上一主題 發帖

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

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

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

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

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

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

回復 3# av8d


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

TOP

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

回復 5# 准提部林


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

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

TOP

回復 6# av8d


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

TOP

回復 7# 准提部林


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

TOP

回復 5# 准提部林


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

    總表重複2.rar (26 KB)

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

TOP

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

        靜思自在 : 得理要饒人,理直要氣和。
返回列表 上一主題