Excel 如何从VBA代码中排除某些图纸？_Excel_Vba

Excel 如何从VBA代码中排除某些图纸？

excel vba

Excel 如何从VBA代码中排除某些图纸？,excel,vba,Excel,Vba,我想尝试从VBA代码设计的操作中排除工作簿中的某些工作表。它基本上比较了所有的表，最后给了我在一个新的表中发现的任何副本，称为确认层。我不确定这是否是最有效的方法，但它确实有效 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

我想尝试从VBA代码设计的操作中排除工作簿中的某些工作表。它基本上比较了所有的表，最后给了我在一个新的表中发现的任何副本，称为确认层。我不确定这是否是最有效的方法，但它确实有效

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

关于如何从我的更大的VBA代码中排除列出的工作表，有什么建议吗？

在您的新代码的基础上，我做了一些修改，以使其更具可读性并进行了一些更正。我还加入了一些东西以加快速度。
我仍然不理解的是你在“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

选项显式
公害
公共sbLayLR尽可能长
公共场所只要
公共车道2LR，只要
公共冲突
公共ws-As工作表
公共wb作为工作簿
公共currentWS As工作表
Public currentWSLastRow尽可能长
公共CritWSLastRow尽可能长
将CritWS设置为工作表
子计时器（）
双倍
双倍调暗
作为变量的模糊时间
sT=现在（）
呼叫LayRunOrder
timetake=格式（（Now（）-sT），“HH:mm:ss”）
调试。打印时间
端接头
子订单（）
Application.DisplayAlerts=False
Application.ScreenUpdating=False
Application.Calculation=xlCalculationManual'dann aber wo notwendig Application.Calculation
呼叫设置
呼叫LoopWSs
打电话给FinishUP
Application.DisplayAlerts=True
Application.ScreenUpdating=True
Application.Calculation=xlCalculationAutomatic
端接头
子设置（）
暗淡的床单以床单的形式排列
Set sheetsArray=ActiveWorkbook.Sheets（数组（“安全下注”、“第一次下注”、“第二次下注”））
将图纸对象设置为工作表
'从sheetsArray更改每张图纸上范围'a1'的值
对于sheetsArray中的每个sheetObject
“做点什么
ws.Tab.Color=xlNone
如果ws.FilterMode=True，则ws.ShowAllData
如果ws.AutoFilterMode=True，则ws.AutoFilterMode=False
下一页对象
Worksheets.Add.Name=“标准”
工作表（“确认层”）。范围（“1:1”）。复制工作表（“标准”）。范围（“1:1”）
端接头
子循环wss（）
对于此工作簿中的每个准则。工作表
选择Case CritWS.Name
案例为=“安全投注”、“PP1”、“PP2”、“足总赛车”、“足总赛车2”、“足总赛车3”、“首次登场驱逐舰”
“什么也不做
其他情况
CritWSLastRow=CritWS.Cells（Rows.Count，1）.End（xlUp）.Row
对于此工作簿中的每个currentWS。工作表
如果CritWS.Name=currentWS.Name，则转到跳过
如果currentWS.Name=“Criteria”，则转到跳过
如果currentWS.Name=“已确认”，则转到跳过
currentWSLastRow=currentWS.Cells（Rows.Count，1）.End（xlUp）.Row
呼叫过滤器
currentWS.Tab.Color=vbWhite
跳过：
下一个currentWS
CritWS.Tab.Color=vbWhite
结束选择
下一个CritWS
端接头
子过滤器SS（）
CritWS.Range（“a2:a”和CritWSLastRow）。复制工作表（“标准”）.Range（“a2”）
CritWS.Range（“b2:b”和CritWSLastRow）。复制工作表（“标准”）.Range（“b2”）
CritWS.Range（“h2:h”和CritWSLastRow）。复制工作表（“标准”）.Range（“h2”）
当前ws.Activate
如果currentWS.Cells（Rows.Count，1）.End（xlUp）.Row<2，则
后藤滤器
如果结束
confLaysLR=工作表（“已确认层”）。单元格（Rows.Count，1）。结束（xlUp）。行
'范围（“A1:W”和currentWSLastRow）.高级筛选操作：=XLFilterPlace，标准范围：=Sheets（“标准”）.范围（“A1:W”和标准），唯一：=False
范围（“A1:W”和currentWSLastRow）。高级筛选操作：=xlFilterCopy，标准范围：=Sheets（“标准”）。范围（“A1:W”和CritWSLastRow）_
copytorange:=工作表（“已确认的层”）。范围（“A”和“confLaysLR+1”），唯一：=假
'范围（“a2”）.CurrentRegion.Offset（1，0）.特殊单元格（xlCellTypeVisible）.复制工作表（“已确认的层”）.Range（“a”和confLaysLR+1）
Skipfilter：
端接头
子FinishUP（）
Application.DisplayAlerts=False
工作表（“标准”）。删除
Application.DisplayAlerts=True
工作表（“已确认层”）。激活
范围（“a:x”）。RemovedUpplicates列：=数组（1,2,8），标头：=xlYes
端接头

作为一个例子，我通过在图纸名称的开头添加一个

。

。然后，当宏运行时，它会查找这个对象。问题是原始代码没有使用任何图纸名称。它假定工作簿中有所有工作表，因此无处可向工作表名称添加。你能举例说明你的意思吗？感谢你，我的意思是，去改变你想要排除的标签的名称。在它前面放一个

。

。现在，在迭代代码中，如果工作表以

开头，请忽略它。代码中唯一要做的就是检查。
我不会在选择框中添加退出子项。如果第一张表是安全投注
，它将退出子表而不检查其他表-要么留空，要么添加注释“不做任何事”
。也可能不使用ActiveWorkbook
，因为您无法确定代码作用于哪个工作簿。在末尾添加工作表时，可以使用变量-Set wrksht=thiswoolk.worksheets.add…。wrksht.name=“Criteria”第一点绝对正确，我在做“for each”之前就这么做了。。。我编辑说，其他几点可以由HONKIN自己完成……不幸的是，这不起作用，因为没有一张表被排除在下面的内容之外。我实际上想做的是将10张纸中的3张相互比较，并将这3张纸中的任何重复条目复制到确认的表格中。我宁愿不去
    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