Как я могу исключить определенные листы из кода VBA? - PullRequest
Новая
       0

Как я могу исключить определенные листы из кода VBA?

1 голос
/ 10 марта 2020

Я хочу попытаться исключить определенные листы из моей рабочей книги из действий, для которых предназначен код 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

Я рассмотрел возможность использования Select Case для исключения рассматриваемых листов, но не смог получить это работать на всех.

Это то, что я собрал, чтобы, надеюсь, сделать исключение листов. Я попытался ввести его в макросе SetUp, но действительно колебался относительно того, что иметь в Case Else. Я попытался добавить весь остальной код для этого конкретного макроса и завершить его с помощью функции «Выбор конца», но он не сработал. 

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?

1 Ответ

0 голосов
/ 10 марта 2020

на основе вашего нового кода я внес несколько поправок, чтобы сделать его более читабельным и внес исправления. Также я добавляю некоторые вещи, чтобы сделать это быстрее.
Что я до сих пор не понимаю, это то, что вы делаете в «LoopWSs» - вы делаете там двойной l oop, то есть если у вас 10 рабочих листов, у вас есть 10x10 = 100 раз больше l oop. Но если это работает, зачем? 

    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
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...