通过 MS Access VBA 重命名工作表

a） 您应该确切地告诉 VBA 引擎要在哪个对象上工作。例如，若要读取单元格内容，请使用

scacVar = xlsheetC.Range("E" & i).Value2

要复印工作表，请使用

xlsheetC.Copy After:=xlbookC.Sheets(xlbookC.Sheets.Count)

b） 虽然它有效，但我建议不要假设复制的工作表得到了确切的名称。复制的工作表将始终是活动工作表，因此请使用Sheet4 (2)

Set newSheet = xlappC.ActiveSheet

请注意，Access VBA 环境对 ActiveSheet 一无所知，因此应指定这是 Excel Application 对象的成员。

c） 设置工作表名称的正确方法是。但是，当您要分配的名称无效（例如空）时，您会收到错误消息。使用调试器检查内容，以防发生错误newSheet.Name = ...scacVar

更新正如 BigBen 所指出的，您应该使用一个新变量来分配新创建的工作表，因为您想指向载体工作表。我给它起了个名字.xlsheetCnewSheet

避免和隐式工作簿/工作表引用应该可以解决您的问题。另外，应避免“重复使用”......您需要在整个迭代中引用它。ActivatexlsheetCWorksheet

For i = 2 to n
     scacVar = xlsheetC.Range("E" & i).Value2

     If Not WorksheetExists(scacVar, xlbookC) Then
          With xlbookC
              .Worksheets("Sheet4").Copy After:=.Sheets(.Sheets.Count)

              .Sheets(.Sheets.Count).Name = scacVar
          End With
     End If
Next

换句话说，这是有问题的：

scacVar = Range("E" & i).Value2

它隐含地：

scacVar = ActiveSheet.Range("E" & i).Value2

但是当您复制工作表时会发生变化！ActiveSheet

Access：从模板创建 Excel 工作表

以前

后

守则

• 我成功地运行了 、 、 、 和 中的代码。AccessExcelPowerPointPublisherWord
• 该代码使用早期绑定，即它需要创建对 Microsoft Excel 对象库的引用（当然不是在 Excel 中）。用。VBE --> Tools --> References

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates and renames copies of a (template) worksheet
'               using a list (column) in another worksheet.
' Flow:         It launches a new instance of Excel, opens the workbook,
'               applies the changes, and saves and closes the workbook
'               before closing the instance.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CreateWorksheetsFromTemplate()
    Const PROC_TITLE As String = "Create Worksheets From Template"
    Const DEBUG_PRINT_PROGRESS As Boolean = True
    Dim WasSuccess As Boolean
    
    On Error GoTo ClearError
    
    ' Define constants.
    
    ' Set the file path for the Kichler Master file.
    Const FILE_PATH As String = "C:\Test\Test.xlsx"
    Const SRC_TEMPLATE As String = "Sheet4"
    Const SRC_LIST As String = "Carrier Pay - Tab to Delete"
    Const SRC_FIRST_LIST_CELL As String = "E2"
        
    If DEBUG_PRINT_PROGRESS Then
        Debug.Print "Running """ & PROC_TITLE & """."
    End If
    
    ' Check if the file exists.
    If Len(Dir(FILE_PATH)) = 0 Then
        MsgBox "The file """ & FILE_PATH & """ doesn't exist!", _
            vbCritical, PROC_TITLE
        GoTo ProcExit
    End If
    
    If DEBUG_PRINT_PROGRESS Then
        Debug.Print "Found the file """ & FILE_PATH; """."
    End If
    
    ' Create a reference to a newly launched instance of Excel (early binding).
    Dim xlApp As Excel.Application: Set xlApp = New Excel.Application
    'xlApp.Visible = True ' default is 'False'
    
    If DEBUG_PRINT_PROGRESS Then
        Debug.Print "New instance of Excel created."
    End If
    
    ' Open and create a reference to the workbook.
    Dim wb As Excel.Workbook: Set wb = xlApp.Workbooks.Open(FILE_PATH)
    
    If DEBUG_PRINT_PROGRESS Then
        Debug.Print "Workbook """ & wb.Name & """ opened."
    End If
    
    ' Create references to the worksheets
    Dim wsTemp As Excel.Worksheet: Set wsTemp = wb.Worksheets(SRC_TEMPLATE)
    Dim wsList As Excel.Worksheet: Set wsList = wb.Worksheets(SRC_LIST)
    
    If DEBUG_PRINT_PROGRESS Then
        Debug.Print "References to worksheets """ & wsTemp.Name & """ and """ _
            & wsList.Name & """ created."
    End If
    
    ' Create a reference to the range containing the list.
    Dim rgList As Excel.Range:
    Set rgList = RefColumnRangeEnd(wsList.Range(SRC_FIRST_LIST_CELL))
    
    ' Check if the list is empty.
    If rgList Is Nothing Then
        MsgBox "The list is empty.", vbCritical, PROC_TITLE
        GoTo ProcExit
    End If
    
    If DEBUG_PRINT_PROGRESS Then
        Debug.Print "Found the list in """ & rgList.Address(0, 0) & """."
    End If
    
    ' Return the list in an array.
    Dim Data(): Data = GetRangeColumn(rgList)
    
    If DEBUG_PRINT_PROGRESS Then
        On Error Resume Next
            Debug.Print "Returned the following list in the array:" _
                & vbLf & Join(xlApp.Transpose(Data), vbLf)
        On Error GoTo ClearError
    End If
    
    ' Declare new variables used in the upcoming loop.
    Dim SheetName As Variant, r As Long, ErrNumber As Long, Msg As String
    Dim IsCopyAvailable As Boolean
    
    ' For each sheet name in the array, copy the template worksheet
    ' as the last sheet and rename it.
    For r = 1 To UBound(Data, 1)
        SheetName = Data(r, 1)
        If Not IsError(SheetName) Then ' the corresponding cell has no error
            If Len(SheetName) > 0 Then ' the corresponding cell is not blank
                If IsSheetNameAvailable(wb, SheetName) Then ' sheet doesn't exist
                    If DEBUG_PRINT_PROGRESS Then
                        Debug.Print r & ".) Processing name """ & SheetName _
                            & """:"
                    End If
                    If Not IsCopyAvailable Then ' no copy available
                        wsTemp.Copy After:=wb.Sheets(wb.Sheets.Count)
                        IsCopyAvailable = True
                        If DEBUG_PRINT_PROGRESS Then
                            Debug.Print "    Template copied."
                        End If
                    Else ' a copy is available; do nothing
                        If DEBUG_PRINT_PROGRESS Then
                            Debug.Print "    Template not copied; " _
                                & "a copy is already available!"
                        End If
                    End If
                    If RenameSheet(wb.Sheets(wb.Sheets.Count), SheetName) Then
                        If DEBUG_PRINT_PROGRESS Then
                            Debug.Print "    Created """ & SheetName & """."
                        End If
                        IsCopyAvailable = False
                    Else ' could not be renamed; do nothing
                        If DEBUG_PRINT_PROGRESS Then
                            Debug.Print "    Not created the invalid """ _
                                & SheetName & """!"
                        End If
                    End If
                Else ' sheet exists (sheet name is not available); do nothing
                    If DEBUG_PRINT_PROGRESS Then
                        Debug.Print r & ".) A sheet named """ & SheetName _
                            & """" & " already exists."
                    End If
                End If
            Else ' the corresponding cell is blank; do nothing
                If DEBUG_PRINT_PROGRESS Then
                    Debug.Print r & ".) The corresponding cell is blank!"
                End If
            End If
        Else ' the corresponding cell has an error; do nothing
            If DEBUG_PRINT_PROGRESS Then
                Debug.Print r & ".) The corresponding cell has an error!"
            End If
        End If
    Next r
    
    ' Delete excessive worksheet and close saving changes.
    
    If IsCopyAvailable Then ' there is an extra worksheet; delete it
        xlApp.DisplayAlerts = False ' delete without confirmation
             wb.Sheets(wb.Sheets.Count).Delete
        xlApp.DisplayAlerts = True
        If DEBUG_PRINT_PROGRESS Then
            Debug.Print "Deleting excessive worksheet!"
        End If
    'Else ' there is no extra worksheet; do nothing
    End If
    
    wb.Close SaveChanges:=True
    
    If DEBUG_PRINT_PROGRESS Then
        Debug.Print "Workbook saved and closed."
    End If
    
    WasSuccess = True
    
    If DEBUG_PRINT_PROGRESS Then
        Debug.Print "The code ran successfully."
    End If

ProcExit:
    On Error Resume Next
        ' Close the workbook.
        If Not WasSuccess Then
            If Not wb Is Nothing Then
                wb.Close SaveChanges:=False
                If DEBUG_PRINT_PROGRESS Then
                    Debug.Print "Workbook not saved but closed!"
                End If
            End If
        End If
        ' Close the instance.
        If Not xlApp Is Nothing Then
            xlApp.Quit
            If DEBUG_PRINT_PROGRESS Then
                Debug.Print "Quitting Excel."
            End If
        End If
    On Error GoTo 0
    
    If WasSuccess Then
        MsgBox "Worksheets successfully created.", vbInformation, PROC_TITLE
    End If
    
    Exit Sub
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    If DEBUG_PRINT_PROGRESS Then
        Debug.Print "An error occurred!"
    End If
    Resume ProcExit
End Sub

帮助 - 引用单列范围

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the single-column range between a given
'               cell ('firstCell') and the bottom-most visible occupied cell.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumnRangeEnd( _
    ByVal firstCell As Excel.Range) _
As Excel.Range

    If firstCell Is Nothing Then Exit Function
    
    Dim rg As Excel.Range
    
    With firstCell
        Dim LastRow As Long: LastRow = .Worksheet _
            .Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row
        If LastRow < .Row Then Exit Function
        Set rg = .Resize(LastRow - .Row + 1, 1)
    End With
    
    Set RefColumnRangeEnd = rg

End Function

“帮助 - 获取范围”列

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the data from an Excel range's column ('ColumnNumber')
'               in a 2D one-based single-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRangeColumn( _
    ByVal rg As Excel.Range, _
    Optional ByVal ColumnNumber As Long = 1) _
As Variant
    
    If rg Is Nothing Then Exit Function
    If ColumnNumber < 0 Then Exit Function
    If rg.Columns.Count < ColumnNumber Then Exit Function
    
    Dim Data() As Variant
    
    If rg.Rows.Count = 1 Then
        ReDim Data(1 To 1, 1 To 1)
        Data(1, 1) = rg.Value
    Else
        Data = rg.Value
    End If
    
    GetRangeColumn = Data

End Function

帮助 - 工作表名称是否可用

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a boolean indicating whether an Excel workbook ('wb')
'               doesn't contain a sheet with the specified name ('SheetName').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function IsSheetNameAvailable( _
    ByVal wb As Excel.Workbook, _
    ByVal SheetName As String) _
As Boolean
    
    Dim sh As Object
    
    On Error Resume Next
        Set sh = wb.Sheets(SheetName)
    On Error GoTo 0
    
    IsSheetNameAvailable = sh Is Nothing

End Function

帮助 - 重命名工作表

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Attempts to rename an Excel sheet ('sh') with a given name
'               ('NewSheetName') and returns a boolean indicating
'               whether it was successful.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RenameSheet( _
    ByVal sh As Object, _
    ByVal NewSheetName As String) _
As Boolean
    
    Dim ErrNumber As Long
    
    On Error Resume Next
        sh.Name = NewSheetName
        ErrNumber = Err.Number
    On Error GoTo 0
    
    RenameSheet = ErrNumber = 0

End Function

日志 （DEBUG_PRINT_PROGRESS = true）

Running "Create Worksheets From Template".
Found the file "C:\Test\Test.xlsx".
New instance of Excel created.
Workbook "Test.xlsx" opened.
References to worksheets "Sheet4" and "Carrier Pay - Tab to Delete" created.
Found the list in "E2:E11".
1.) Processing name "John":
    Template copied.
    Created "John".
2.) Processing name "Mary":
    Template copied.
    Created "Mary".
3.) The corresponding cell is blank!
4.) The corresponding cell has an error!
5.) The corresponding cell is blank!
6.) The corresponding cell has an error!
7.) Processing name "/Liam/":
    Template copied.
    Not created the invalid "/Liam/"!
8.) Processing name "Peter":
    Template not copied; a copy is already available!
    Created "Peter".
9.) Processing name "Frank":
    Template copied.
    Created "Frank".
10.) Processing name "Super*Sue":
    Template copied.
    Not created the invalid "Super*Sue"!
Deleting excessive worksheet!
Workbook saved and closed.
The code ran successfully.
Quitting Excel.