Running a Procedure in an Array

Question

I have a procedure to create a new sheet based on available data. Basically, it creates a sheet based on the name of the data. The code is written as follows. It does work actually if I assign the procedure one by one.

Sub new_profile(tankname)
    Sheets.Add After:=ActiveSheet
    Range("B4").Select
    ActiveCell.FormulaR1C1 = tankname
    ActiveSheet.Name = Range("b4").Value

end sub

Due to the fact that I will use this code for another workbook (which means there is no exact amount of data), I try to assign an array to automatically run the procedure all in one without call it one by one. The code is as follow:

Sub calculate_all()

Dim cel As Range
Dim tank_name() As String
Dim i As Integer, j As Integer
Dim n As Integer

i = 11
n = Range("B6").Value

ReDim tank_name(i)

For Each cel In ActiveSheet.Range(Cells(11, 2), Cells(11 + n, 2))
    tank_name(i) = cel.Value
    i = i + 1
    
    new_profile tank_name(i)
    ReDim Preserve tank_name(i)
    
Next cel

    

End Sub

Unfortunately, it becomes error and shows the message "subscript out of range". How could I solve this problem?

Answer 1

For Each Element in Array Run a Procedure

• Let's say that creating a new profile means adding a new sheet, renaming it and writing the name to a cell.
• The 1st, main procedure createProfiles does the previously mentioned only if a worksheet with the current name in the TankNames array doesn't exist.
• The 2nd procedure deleteProfiles deletes all sheets if their names exist in the TankNames array.
• The 3rd and the 4th procedure are called by both previously mentioned procedures, while the 5th is obviously only called by the main procedure.
• Before running any of the first two procedures, adjust the constants in them to fit your needs.

The Code

Option Explicit

Sub createProfiles()

    ' Source
    Const wsName As String = "Sheet1" ' Tab Name
    Const FirstRow As Long = 11
    Const NameCol As Variant = "B" ' e.g. 1 or "A", 2 or "B"...
    ' Target
    Const CellAddress As String = "B4"
    ' Other
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define Source Worksheet.
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    ' Write tank names from Source Worksheet to TankNames array.
    Dim TankNames As Variant
    getColumn TankNames, ws, NameCol, FirstRow

    Dim i As Long
    ' Loop through elements of TankNames array.
    For i = 1 To UBound(TankNames)
        ' For each tank name create a new profile.
        If Not foundSheetName(wb, TankNames(i, 1)) Then
            Call createProfile wb, TankNames(i, 1), CellAddress
        End If
    Next i

End Sub

Sub deleteProfiles()
    ' Source
    Const wsName As String = "Sheet1" ' Tab Name
    Const FirstRow As Long = 11
    Const NameCol As Variant = "B" ' e.g. 1 or "A", 2 or "B"...
    ' Other
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define Source Worksheet.
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    ' Write tank names from Source Worksheet to TankNames array.
    Dim TankNames As Variant
    getColumn TankNames, ws, NameCol, FirstRow

    Dim i As Long
    ' Loop through elements of TankNames array.
    For i = 1 To UBound(TankNames)
        ' For each tank name delete profile (sheet).
        If foundSheetName(wb, TankNames(i, 1)) Then
            Application.DisplayAlerts = False
            wb.Worksheets(TankNames(i, 1)).Delete
            Application.DisplayAlerts = True
        End If
    Next i

End Sub

Sub getColumn(ByRef Data As Variant, _
              Sheet As Worksheet, _
              Optional ByVal ColumnID As Variant = 1, _
              Optional ByVal FirstRow As Long = 1)
    
    Data = Empty
    If Sheet Is Nothing Then Exit Sub
    
    Dim rng As Range
    Set rng = Sheet.Columns(ColumnID).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Sub
    If rng.Row < FirstRow Then Exit Sub
    Set rng = Sheet.Range(Sheet.Cells(FirstRow, ColumnID), rng)
    
    If rng.Cells.Count > 1 Then
        Data = rng.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
    End If
    
End Sub
    
Function foundSheetName(Book As Workbook, _
                        Optional ByVal SheetName As String = "Sheet1") _
         As Boolean
    If Book Is Nothing Then Set Book = ActiveWorkbook
    On Error Resume Next
    Dim ws As Worksheet: Set ws = Book.Worksheets(SheetName)
    If Err.Number = 0 Then foundSheetName = True
End Function

Sub createProfile(Book As Workbook, _
                  ByVal NewName As String, _
                  ByVal NameCellAddress As String)
    Dim ws As Worksheet
    Set ws = Book.Worksheets.Add(After:=Book.Sheets(Book.Sheets.Count))
    With ws
        .Name = NewName
        .Range(NameCellAddress) = NewName
    End With
End Sub