chrisovo的部落格

網路問題：http://club.excelhome.net/thread-1393985-1-1.html

重點公式：Union() - 選取多個不同列不同欄之儲存格

我的解法：

Sub test()

Dim sh As Worksheet
Dim Arr, Brr, d
Dim Row_E%, Row_F%
Dim rng As Range

Set d = CreateObject("scripting.dictionary")

Row_F = [F65535].End(3).Row

Arr = Range("F1:F" & Row_F)

'抓出要拿來篩選的值

For i = 4 To Row_F

    d(Arr(i, 1)) = ""

Next

'將keys賦予數列A，方便接下來跑迴圈

A = d.keys

'每一個工作表都要運行，含有"休眠"此字詞的工作表除外

For Each sh In Worksheets

  sh.select

  If Not sh.Name Like "*" & "休眠" & "*" Then

'對將工作表的E欄設為數列
        Row_E = sh.[E65535].End(3).Row
        Brr = sh.Range("E1:E" & Row_E)

'比對篩選值和工作表的值是否有相同
        For i = 0 To UBound(A, 1)
            For j = 4 To Row_E

'如果相同的話，將此有相同資料的儲存格列數（物件）用set賦予給Rng變數

'若Rng變數裡面已經有東西了（代表之前的迴圈已經有發現其他相同的資料，且將值賦予給rng）

'那就用Union方法將新的列數與先前發現的列數合併 set rng = Union(rng,sh.rows(j))
                If A(i) = Brr(j, 1) Then
                    If rng Is Nothing Then
                        Set rng = sh.Rows(j)
                    Else
                        Set rng = Union(rng, sh.Rows(j))
                    End If
                End If
            Next j
        Next i

'如果rng變數有東西的話，就刪除用entirerow.delete將rng內的列數刪除
        If Not rng Is Nothing Then rng.EntireRow.Delete
        Erase Brr
        Set rng = Nothing
        
    End If

Next sh

End Sub

其他解法：

Sub test()
 Dim m&, i&
 Set d = CreateObject("scripting.dictionary")
 m = Cells(Rows.Count, 6).End(3).Row
 arr = Range("F1:f" & m)
 For i = 4 To UBound(arr)
     d(arr(i, 1)) = ""
     Next
For Each sh In Worksheets
        If Not sh.Name Like "*" & "休眠" & "*" Then 
       sh.Select

'呼叫副程式dd
              Call dd
        End If
    Next
   MsgBox "ss"
End Sub

Sub dd()
     Dim rng As Range, n&, brr, j&
     Application.ScreenUpdating = False
     n = sh.Cells(sh.Rows.Count, 5).End(3).Row
     brr = sh.Range("E1:E" & n)
     
     For j = 4 To UBound(brr)
     '在此藍大是直接用d.exists(brr(j,5))是否存在，來判斷字典內是否有此key值，可以省略掉一個跑key值的迴圈
         If d.exists(brr(j, 1)) Then
             If rng Is Nothing Then
                 Set rng = sh.Rows(j)
             Else
                 Set rng = Union(rng, sh.Rows(j))
             End If
         End If
     Next j
     
     If Not rng Is Nothing Then rng.EntireRow.Delete
     Application.ScreenUpdating = True
 End Sub