CODEWITHSUNDEEP
vbaexcelif-statementlookup
Tom
Tom

Reputation: 37

VBA Excel Look up sheet name, IF tab has 'started' then loop through these sheets

I have a function in my VBA script that currently loops through all numerical sheet names and performs a function. 001, 002, 003 etc.

I'm hoping to refine this so that only sheet names that are marked as 'started' are looked at. I have a sheet called 'Initiative Index' in the same workbook which lists the sheet numbers (with hyperlinks, hope this doesn't cause an issue) in column 1 (A), in the same table there is a 'status'column 5 (E) which for each sheet contains 'started', 'idea', 'hold'.

The VBA script then goes on to copy and paste certain bits on info from the relevant tabs in to a new sheet called actions summary.

I'm hoping to simply replace the below section of code to do this. Any ideas?

 'Loop through all sheets in the workbook
For Each ws In wb.Sheets
    'Only look for worksheets whose names are numbers (e.g. "001", "002", etc)
    If IsNumeric(ws.Name) Then

UPDATE: For context, full code here:

    Sub UpDate_List_v2()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsSum As Worksheet
    Dim rLastCell As Range
    Dim lCalc As XlCalculation
    Dim bHasHeaders As Boolean


    'Turn off calculation, events, and screenupdating
    'This allows the code to run faster and prevents "screen flickering"
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set wb = ActiveWorkbook

    'Check if Actions Summary sheet exists already or not
    On Error Resume Next
    Set wsSum = wb.Sheets("Actions summary")
    On Error GoTo 0

    If wsSum Is Nothing Then
        'Does not exist, create it
        Set wsSum = wb.Sheets.Add(Before:=wb.Sheets(1))
        wsSum.Name = "Actions summary"
        bHasHeaders = False
    Else
        'Already exists, clear previous data
        wsSum.UsedRange.Offset(1).Clear
        bHasHeaders = True
    End If

    'Loop through all sheets in the workbook
    For Each ws In wb.Sheets
        'Only look for worksheets whose names are numbers (e.g. "001", "002",       etc)
 '-----------------------------------
    If IsNumeric(ws.Name) Then
                l = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
                For i = 1 To l
                    If ActiveWorkbook.Worksheets("Initiative Index").Range("A" & i).Value = ws.Name And ActiveWorkbook.Worksheets("Initiative Index").Range("E" & i).Value <> "Started" Then Exit If
    '--------------------------------------
            'Check if the "Actions Summary" sheet already has headers
            If bHasHeaders = False Then
                'Does not have headers yet
                With ws.Range("A8:M8")
                    'Check if this sheet has headers in A8:G8
                    If WorksheetFunction.CountBlank(.Cells) = 0 Then
                        'This sheet does have headers, copy them over
                        .Copy wsSum.Range("A1")
                        bHasHeaders = True
                    End If
                End With
            End If

            'Find the last row of the sheet
            Set rLastCell = ws.Cells.Find("*", ws.Range("A1"), SearchDirection:=xlPrevious)
            If Not rLastCell Is Nothing Then
                'Check if the last row is greater than the header row
                If rLastCell.Row > 8 Then
                    'Last row is greater than the header row so there is data
                                    'Check if the "Actions Summary" sheet has enough rows to hold the data
                                    If wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Row + rLastCell.Row - 8 > wsSum.Rows.Count Then
                                        'Not enough rows, return error and exit the subroutine
                                        MsgBox "There are not enough rows in the summary worksheet to place the data.", , "Data Overflow"
                                        Exit Sub
                                    Else
                        'Does have enough rows, copy the data - Values
                        ws.Range("A9:M" & rLastCell.Row).Copy
                        With wsSum.Cells(wsSum.Rows.Count, "A").End(xlUp).Offset(1)
                            .PasteSpecial xlPasteValues
                            .PasteSpecial xlPasteFormats
                        End With
                    End If
                End If
            End If
           Next   'here
        End If
    Next ws

        'Sheets("Actions summary").Columns("H:L").EntireColumn.Delete       'Delete unwanted columns
        'Sheets("Actions summary").Columns("H:L").Hidden = True              'Hide unwanted columns
        Worksheets("Actions summary").Columns("H").Hidden = True
        Worksheets("Actions summary").Columns("J").Hidden = True
        Worksheets("Actions summary").Columns("L").Hidden = True
        Sheets("Actions summary").Columns("H").Style = "currency"           'Set to £

    Application.CutCopyMode = False                         'Remove the cut/copy border
    'wsSum.Range("A1").CurrentRegion.EntireColumn.AutoFit    'Autofit columns on the "Actions Summary" sheet

    'Turn calculation, events, and screenupdating back on
    With Application
        '.Calculation = lCalc
        Application.Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Upvotes: 0

Views: 1478

Answers (1)

Wouter
Wouter

Reputation: 612

If IsNumeric(ws.Name) Then
    l = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
    For i = 1 To l
        If ActiveWorkbook.Worksheets("Initiative Index").Range("A" & i).Value = ws.Name And ActiveWorkbook.Worksheets("Initiative Index").Range("E" & i).Value = "Started" Then
            'run code
        Else
            Exit If
        End If
    Next
End If

Perhaps this could help you. The code first checks if the value you assigned (001) is in the list specified in Initiative Index. It also checks if the value in column E is equal to Started. If so, you'll be able to run your desired code. If not, you can quit the If-statement and don't run the code.

Update 1: You may also try something like the code below, this way you have to replace the code you suggested by everything between the -----, the next you'll have to place here: 

          End If
        Next   'here 
    End If
Next ws

The code: 

   '-----------------------------------        
    If IsNumeric(ws.Name) Then
                l = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
                For i = 1 To l
                    If ActiveWorkbook.Worksheets("Initiative Index").Range("A" & i).Value = ws.Name And ActiveWorkbook.Worksheets("Initiative Index").Range("E" & i).Value <> "Started" Then Exit If
    '--------------------------------------
                Next
     End If

Upvotes: 1

Related Questions