excel - 如何从 VBA 代码中排除某些工作表？

Question

我想尝试从 VBA 代码设计的操作中排除工作簿中的某些工作表。它基本上将所有工作表相互比较，最后给我在一张名为 Confirmed Lays 的新工作表中找到的任何重复项。我不确定这是否是最有效的方法，但它确实有效。

Option Explicit

Public critLR As Long
Public sbLayLR As Long
Public faLays1LR As Long
Public faLays2LR As Long
Public confLaysLR As Long
Public ws As Worksheet
Public wb As Workbook
Public currentWS As Worksheet
Public currentWSLastRow As Long
Public CritWSLastRow As Long
Dim CritWS As Worksheet

Sub LayRunOrder()

Call SetUp
Call LoopWSs
Call FinishUP

End Sub

Sub SetUp()

For Each ws _
In ActiveWorkbook.Sheets

Select Case ws.Name
    Case Is = "Safe Bets", "PP1", "PP2", "FA Racing", "FA Racing 2", "FA Racing 3", "Debut Destroyer"
        'Do Nothing
    Case Else
   ws.Tab.Color = xlNone

'ws.Range("a1").CurrentRegion.Columns.AutoFit
'ws.Range("a1").CurrentRegion.Rows.AutoFit

    If ws.FilterMode = True Then
        ws.ShowAllData
    End If

    If ws.AutoFilterMode = True Then
        ws.AutoFilterMode = False
    End If

    If ws.Name = "Criteria" Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
End Select

Next ws

Worksheets.Add.Name = "Criteria"
Worksheets("Confirmed Lays").Range("1:1").Copy Worksheets("Criteria").Range("1:1")

End Sub

Sub LoopWSs()

For Each CritWS In ThisWorkbook.Worksheets
Select Case ws.Name
    Case Is = "Safe Bets", "PP1", "PP2", "FA Racing", "FA Racing 2", "FA Racing 3", "Debut Destroyer"
        'Do Nothing
    Case Else

    CritWSLastRow = CritWS.Cells(Rows.Count, 1).End(xlUp).Row

    For Each currentWS In ThisWorkbook.Worksheets
        If CritWS.Name = currentWS.Name Then
            GoTo Skip
        End If

        If currentWS.Name = "Criteria" Then
            GoTo Skip
        End If
        If currentWS.Name = "Confirmed Lays" Then
            GoTo Skip
        End If

        currentWSLastRow = currentWS.Cells(Rows.Count, 1).End(xlUp).Row
        Call FilterWSs
        currentWS.Tab.Color = vbWhite
Skip:
    Next currentWS
    CritWS.Tab.Color = vbWhite
Next CritWS
End Select

End Sub

Sub FilterWSs()

    CritWS.Range("a2:a" & CritWSLastRow).Copy Worksheets("Criteria").Range("a2")
    CritWS.Range("b2:b" & CritWSLastRow).Copy Worksheets("Criteria").Range("b2")
    CritWS.Range("h2:h" & CritWSLastRow).Copy Worksheets("Criteria").Range("h2")

    currentWS.Activate

    If currentWS.Cells(Rows.Count, 1).End(xlUp).Row < 2 Then
        GoTo Skipfilter
   End If

    confLaysLR = Worksheets("Confirmed Lays").Cells(Rows.Count, 1).End(xlUp).Row

'Range("A1:W" & currentWSLastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Sheets("Criteria").Range("A1:W" & critLR), Unique:=False
Range("A1:W" & currentWSLastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Criteria").Range("A1:W" & CritWSLastRow), _
    copytorange:=Sheets("Confirmed Lays").Range("A" & confLaysLR + 1), Unique:=False

'Range("a2").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Worksheets("Confirmed Lays").Range("a" & confLaysLR + 1)

Skipfilter:

End Sub

Sub FinishUP()

Application.DisplayAlerts = False
Worksheets("Criteria").Delete
Application.DisplayAlerts = True

Worksheets("Confirmed Lays").Activate
    Range("a:x").RemoveDuplicates Columns:=Array(1, 2, 8), Header:=xlYes

End Sub

Sub Timer()

Dim sT As Double
Dim eT As Double
Dim TimeTaken As Variant

sT = Now()

Call LayRunOrder

TimeTaken = Format((Now() - sT), "HH:mm:ss")
Debug.Print TimeTaken

End Sub

我已经研究过可能使用 Select Case 来排除有问题的工作表，但根本无法让它工作。

这就是我拼凑起来的，希望能排除床单。我尝试在 SetUp 宏中输入它，但对于在 Case Else 中应该有什么感到很困惑。我尝试将该特定宏的所有其余代码放在其中并以 End Select 结尾，但它无法正常工作。

Sub SetUp()

    Dim ws As Worksheet
    Dim wb As Workbook
    Select Case ws.CodeName
    Case "Safe Bets", "PP1", "PP2", "FA Racing", "FA Racing 2", FA Racing 3”, "Debut Destroyer"
    Case Else
        ws.Tab.Color = xlNone

'ws.Range("a1").CurrentRegion.Columns.AutoFit
'ws.Range("a1").CurrentRegion.Rows.AutoFit

    If ws.FilterMode = True Then
        ws.ShowAllData
    End If

    If ws.AutoFilterMode = True Then
        ws.AutoFilterMode = False
    End If

    If ws.Name = "Criteria" Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
    End Select
Next ws

Worksheets.Add.Name = "Criteria"
Worksheets("Confirmed Lays").Range("1:1").Copy Worksheets("Criteria").Range("1:1")

End Sub

关于如何从我的较大 VBA 代码中排除列出的工作表的任何建议？

Answer 1

在您的新代码的基础上，我进行了一些修改，以使其更具可读性并进行一些更正。我还放了一些东西让它更快。
我仍然不明白的是你在“LoopWSs”中所做的 - 你在那里做一个双循环，这意味着如果你有 10 个工作表，你有 10x10=100 次循环运行。
但如果它有效，为什么要打扰......

    Option Explicit

    Public critLR As Long
    Public sbLayLR As Long
    Public faLays1LR As Long
    Public faLays2LR As Long
    Public confLaysLR As Long
    Public ws As Worksheet
    Public wb As Workbook
    Public currentWS As Worksheet
    Public currentWSLastRow As Long
    Public CritWSLastRow As Long
    Dim CritWS As Worksheet

    Sub Timer()
    Dim sT As Double
    Dim eT As Double
    Dim TimeTaken As Variant

    sT = Now()

    Call LayRunOrder

    TimeTaken = format((Now() - sT), "HH:mm:ss")
    Debug.Print TimeTaken
    End Sub

    Sub LayRunOrder()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual ' dann aber wo notwendig Application.Calculate

    Call SetUp
    Call LoopWSs
    Call FinishUP

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    End Sub

    Sub SetUp()

    Dim sheetsArray As Sheets
    Set sheetsArray = ActiveWorkbook.Sheets(Array("Safe Bets Lay", "FA Lays 1", "FA Lays 2"))

    Dim sheetObject As Worksheet

    ' change value of range 'a1' on each sheet from sheetsArray
    For Each sheetObject In sheetsArray
        'Do something
        ws.Tab.Color = xlNone
        If ws.FilterMode = True Then ws.ShowAllData
        If ws.AutoFilterMode = True Then ws.AutoFilterMode = False

Next sheetObject

Worksheets.Add.Name = "Criteria"
Worksheets("Confirmed Lays").Range("1:1").Copy Worksheets("Criteria").Range("1:1")

End Sub

    Sub LoopWSs()

    For Each CritWS In ThisWorkbook.Worksheets
    Select Case CritWS.Name
        Case Is = "Safe Bets", "PP1", "PP2", "FA Racing", "FA Racing 2", "FA Racing 3", "Debut Destroyer"
            'Do Nothing
        Case Else

        CritWSLastRow = CritWS.Cells(Rows.Count, 1).End(xlUp).Row

        For Each currentWS In ThisWorkbook.Worksheets
            If CritWS.Name = currentWS.Name Then GoTo Skip
            If currentWS.Name = "Criteria" Then GoTo Skip
            If currentWS.Name = "Confirmed Lays" Then GoTo Skip

            currentWSLastRow = currentWS.Cells(Rows.Count, 1).End(xlUp).Row
            Call FilterWSs
            currentWS.Tab.Color = vbWhite

    Skip:
        Next currentWS
        CritWS.Tab.Color = vbWhite
    End Select
    Next CritWS

    End Sub

    Sub FilterWSs()

        CritWS.Range("a2:a" & CritWSLastRow).Copy Worksheets("Criteria").Range("a2")
        CritWS.Range("b2:b" & CritWSLastRow).Copy Worksheets("Criteria").Range("b2")
        CritWS.Range("h2:h" & CritWSLastRow).Copy Worksheets("Criteria").Range("h2")

        currentWS.Activate

        If currentWS.Cells(Rows.Count, 1).End(xlUp).Row < 2 Then
            GoTo Skipfilter
       End If

        confLaysLR = Worksheets("Confirmed Lays").Cells(Rows.Count, 1).End(xlUp).Row

    'Range("A1:W" & currentWSLastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Sheets("Criteria").Range("A1:W" & critLR), Unique:=False
    Range("A1:W" & currentWSLastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Criteria").Range("A1:W" & CritWSLastRow), _
        copytorange:=Sheets("Confirmed Lays").Range("A" & confLaysLR + 1), Unique:=False

    'Range("a2").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Worksheets("Confirmed Lays").Range("a" & confLaysLR + 1)

    Skipfilter:

    End Sub

    Sub FinishUP()

    Application.DisplayAlerts = False
    Worksheets("Criteria").Delete
    Application.DisplayAlerts = True

    Worksheets("Confirmed Lays").Activate
        Range("a:x").RemoveDuplicates Columns:=Array(1, 2, 8), Header:=xlYes

    End Sub