VBA function to extract worksheets with numeric names

Question

I have written some code to extract a list of worksheets in the ActiveWorkbook, but only for sheets that have a numeric name.

This works, but I would like to know the Code Review community's thoughts on my methods used here.

Public Sub listNumberedSheets()

    Dim sheetNumberArray As Variant
    ReDim sheetNumberArray(0)

    Dim x As Long
    x = 0

    Sheets(1).Columns(1).ClearContents

    Dim sht As Worksheet
    For Each sht In ActiveWorkbook.Sheets
        If IsNumeric(sht.Name) Then
            ReDim Preserve sheetNumberArray(x)
            sheetNumberArray(x) = sht.Name
            x = x + 1
        End If

    Next

    Sheets(1).Cells(1, 1).Resize(x, 1).Value = Application.Transpose(sheetNumberArray)

End Sub

Answer 1

Sheets(1).Columns(1).ClearContents

It's not a big deal in this case since the macro is always meant to work with the active workbook, but generally you want to preface a "Sheets" reference with an explicit reference to the workbook.

It's also generally not a good idea to refer to sheets by number. Using sheet names tends to be easier to read/debug.

My recommendation would be to add some parameters to the macro so that you can explicitly specify both a) the workbook whose sheets' names you want to check, and b) the worksheet on which to print the results. You can make the parameters optional if you'd like, and set them to "ActiveWorkbook" and "ActiveWorkbook.Sheets(1)" if they're missing from the call.

Application.Transpose(sheetNumberArray)

Once again, this isn't a huge deal in this particular macro, but Application.Transpose has some significant limitations (it doesn't work with very large arrays) and should be avoided if possible. In your case, since you're eventually just writing the results of your routine to the worksheet, ideally you'd just make your array two-dimensional:

ReDim resultsArr(1 To wb.Sheets.Count, 1 To 1) As Double

But currently that won't work because you're using...

ReDim Preserve sheetNumberArray(x)

Which brings me to my final recommendation: ReDim Preserve has high performance costs, and should be avoided if possible (especially uses like this in which it's called repeatedly). In your case, it's pretty easy to avoid, as you should be able to see in my revised code below.

Sub exampleMacro()

    'Checks sheets in specified workbook, prints to specified worksheet
    Call listNumberedSheets(ThisWorkbook, ThisWorkbook.Sheets("Results"))

    'Checks sheets in active wb, prints to Sheets(1) of active wb
    Call listNumberedSheets

End Sub
Sub listNumberedSheets(Optional wbToCheck As Workbook = Nothing, Optional resultsWS As Worksheet = Nothing)

    If wbToCheck Is Nothing Then
        Set wbToCheck = ActiveWorkbook
    End If

    If resultsWS Is Nothing Then
        Set resultsWS = ActiveWorkbook.Sheets(1)
    End If

    ReDim resultsArr(1 To wbToCheck.Sheets.Count, 1 To 1) As Double
    Dim i As Long
    Dim j As Long
    j = 1
    For i = 1 To wbToCheck.Sheets.Count
        Dim shtName As String
        shtName = wbToCheck.Sheets(i).Name
        If IsNumeric(shtName) Then
            resultsArr(j, 1) = shtName
            j = j + 1
        End If
    Next

    With resultsWS
        .Columns(1).ClearContents
        If j > 1 Then
            .Range(.Cells(1, 1), .Cells(j - 1, 1)).Value = resultsArr
        End If
    End With

End Sub

For maximum flexibility/reusability, I'd probably make it a function instead of a sub. That way it can either write the results to a worksheet OR return the results as an array. I'd also probably change it so that it could check multiple workbooks simultaneously. That definitely complicates the code a bit, but potentially makes it useful in more situations.

Sub exampleMacro()

    'Checks sheets in specified workbooks, prints to specified worksheet
    Call listNumberedSheets(Array(ThisWorkbook, Workbooks("Example workbook.xlsx")), ThisWorkbook.Sheets("Results"))

    'Checks sheets in specified workbook, returns 1d array
    Dim arr As Variant
    arr = listNumberedSheets(ThisWorkbook)

End Sub
Function listNumberedSheets(wbToCheck As Variant, Optional resultsWS As Variant) As Variant

    Dim wbArr As Variant
    If Not IsArray(wbToCheck) Then
        wbArr = Array(wbToCheck)
    Else
        wbArr = wbToCheck
    End If

    Dim sheetCount As Long
    Dim i As Long
    For i = LBound(wbArr) To UBound(wbArr)
        If Not TypeName(wbArr(i)) = "Workbook" Then
            MsgBox "Error: wbToCheck must be either workbook or array of workbooks"
            Stop
            Exit Function
        Else
            sheetCount = sheetCount + wbArr(i).Sheets.Count
        End If
    Next

    ReDim resultsArr(1 To sheetCount, 1 To 1) As Double
    Dim j As Long
    Dim counter As Long
    counter = 1
    For i = LBound(wbArr) To UBound(wbArr)
        For j = 1 To wbArr(i).Sheets.Count
            Dim shtName As String
            shtName = wbArr(i).Sheets(j).Name
            If IsNumeric(shtName) Then
                resultsArr(counter, 1) = shtName
                counter = counter + 1
            End If
        Next
    Next

    If IsMissing(resultsWS) Then
        If j = 1 Then
            listNumberedSheets = ""
        Else
            ReDim finalArr(1 To counter - 1) As Double
            For i = LBound(finalArr) To UBound(finalArr)
                finalArr(i) = resultsArr(i, 1)
            Next
            listNumberedSheets = finalArr
        End If
    ElseIf TypeName(resultsWS) = "Worksheet" Then
        If j > 1 Then
            With resultsWS
                .Columns(1).ClearContents
                .Range(.Cells(1, 1), .Cells(counter - 1, 1)).Value = resultsArr
            End With
        End If
    End If

End Function