[英]How can I exclude certain sheets from VBA code?
我想尝试从 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 代码中排除列出的工作表的任何建议?
在您的新代码的基础上,我做了一些修改,以使其更具可读性并进行更正。 我也放了一些东西让它更快。
我仍然不明白的是你在“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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.