Running a Procedure in an Array - arrays

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