问excel vba代码错误(下标超出范围)
EN

Stack Overflow用户

提问于 2022-11-13 11:00:51

回答 1查看 48关注 0票数 1

嗨，我在excel vba中有一个代码，它使我能够根据单元格值更改工作表名，右键单击工作表名，然后选择(查看代码)，然后粘贴它与工作表运行良好的代码，我做了一个简单的宏，将工作表内容复制到另一个新工作表中，然后粘贴用单元格值更改工作表名称的代码，但是我遇到了一个错误，需要一个宏来添加新的工作表，并将当前的工作表内容复制到新的表中，并使工作表名称依赖于单元格值(b3)，我在视觉基础上有0的经验，这里是感谢帮助我的一些截图。

这是工作表名称代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B3")) Is Nothing Then
        ActiveSheet.Name = ActiveSheet.Range("B3")
    End If
End Sub

我已经解释过了

excel

vba

excel-formula

人脸识别特惠活动

精准实时的人脸检测、分析、识别等服务，在线、离线满足多样需求，可应用于智慧零售、智慧社区、在线娱乐等多种应用场景

回答 1

Stack Overflow用户

发布于 2022-11-15 06:45:31

创建活动工作表的副本

将此代码复制到标准模块中，例如Module1.

Option Explicit

Sub CopyActiveSheet()
    
    ' In the worst case scenario, you'll end up with an additional worksheet
    ' that could not be renamed. If you want to keep this worksheet,
    ' set DeleteIfCannotRename to False.
    Const DeleteIfCannotRename As Boolean = True
    
    ' Invalidate the active sheet.
    Dim sh As Object: Set sh = ActiveSheet
    If sh Is Nothing Then Exit Sub ' no visible workbooks open
    If Not TypeOf sh Is Worksheet Then Exit Sub ' not a worksheet
    
    ' Reference the source worksheet.
    Dim sws As Worksheet: Set sws = ActiveSheet
    
    ' Create a copy.
    sws.Copy After:=sws
    
    ' Reference the copy.
    Dim dws As Worksheet: Set dws = ActiveSheet
    
    ' Write the value form 'B3' to a variable.
    Dim dName As String: dName = CStr(dws.Range("B3").Value)
    
    Dim ErrNumber As Long
    
    ' Prevent error if a sheet with the same name already exists
    ' or the value in 'B3' doesn't contain a valid worksheet name.
    On Error Resume Next ' turn on error-trapping
        ' Attempt to rename.
        dws.Name = dName
        ErrNumber = Err.Number ' store the error number in a variable
    On Error GoTo 0 ' turn off error trapping
    
    ' Delete and inform. Out-comment or delete the 'MsgBox' line(s)
    ' if the message box is too annoying.
    If DeleteIfCannotRename Then ' will delete
        If ErrNumber <> 0 Then
            Application.DisplayAlerts = False
                dws.Delete
            Application.DisplayAlerts = True
            MsgBox "Could not rename to '" & dName & "' so it got deleted.", _
                vbCritical, "CopyActivesheet"
        End If
    Else ' will not delete
        MsgBox "Could not rename to '" & dName & "'.", _
            vbCritical, "CopyActivesheet"
    End If

End Sub