在阵列中运行过程

如何解决在阵列中运行过程

我有一个基于可用数据创建新工作表的过程。基本上，它基于数据名称创建工作表。该代码编写如下。如果我一个接一个地分配过程，它确实可以工作。

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

end sub

由于我将这段代码用于另一个工作簿（这意味着没有确切的数据量），因此，我尝试分配一个数组以自动运行所有过程，而不用一一调用。代码如下：

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

    

结束子

不幸的是，它变为错误并显示消息“下标超出范围”。我该如何解决这个问题？

解决方法

对于数组中的每个元素，运行一个过程

• 假设创建新的配置文件意味着添加新的工作表，将其重命名并将名称写入单元格。
• 第一个主过程createProfiles仅在TankNames数组中具有当前名称的工作表不存在的情况下执行前面提到的操作。
• 第二个过程deleteProfiles删除所有工作表，如果它们的名称存在于TankNames数组中。
• 前面提到的两个过程都调用了第三和第四过程，而第五过程显然只被主过程调用了。
• 在运行前两个过程中的任何一个之前，请调整它们中的常量以适合您的需求。

代码

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
    Call 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,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
    Call getColumn(TankNames,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,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