VBA循环多工作表执行数据复制时出现‘Subscript out of range（下标越界）’及编译错误的解决咨询

Let's break down and fix the issues in your code one by one—these are common pitfalls when working with VBA arrays and error handling:

1. Compile Error: Extra End If #

First, you’ve got an extra End If right after checking my_Filename = False. The single-line If...Then Exit Sub doesn’t need a closing End If, so removing that extra line will resolve the compile error immediately.

2. Subscript Out of Range: Incorrect Split Usage #

This is the main culprit behind your "Subscript out of range" error. When you use Strings.Split without specifying a delimiter, it defaults to spaces. Since your sheet names string uses commas ("MHP60,MHP61,MHP62"), the entire string gets treated as a single array element. So when your loop tries to access wb1.Sheets(sht), it’s looking for a sheet named "MHP60,MHP61,MHP62"—which doesn’t exist.

Fix this by explicitly passing the comma as the delimiter:

SheetNames = Strings.Split("MHP60,MHP61,MHP62", ",")

3. Broken Error Handling for Header Check #

Your error check for tabNames wasn’t working because you reset the error state with On Error GoTo 0 before checking Err.Number. I’ve adjusted this to check if tabNames is Nothing (a more reliable way to detect if SpecialCells failed) and moved the error reset after the check.

4. Variable Declaration & Minor Cleanup #

• Dim i, lastcol As Long declared i as a Variant instead of Long—I fixed this to avoid type mismatches.
• Your Debug.Print line hardcoded "MHP60" instead of using the loop variable sht—now it references the current sheet in the loop.
• I replaced the Evaluate sheet existence check with a direct Set targetSheet approach—it’s more reliable and easier to debug.

Full Corrected Code #

Sub Prepare_CYTD_Report()
    Dim addresses() As String
    Dim addresses2() As String
    Dim SheetNames() As String
    'Dim SheetNames2() As String ' Uncomment if needed later
    Dim wb1 As Workbook, wb2 As Workbook
    Dim my_Filename
    '声明用于存储MHP60、MHP61、MHP62试算平衡表数值的变量
    Dim i As Long, lastcol As Long ' Fixed i's data type
    Dim tabNames As Range, cell As Range ' Fixed tabNames type declaration
    Dim tabName As String
    Dim sht As Variant
    
    addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") '试算平衡表字符串区域
    addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") '上月数据字符串区域
    SheetNames = Strings.Split("MHP60,MHP61,MHP62", ",") ' Added comma delimiter
    'SheetNames2 = Strings.Split("MHP60-CYTDprior,MHP61-CYTDprior,MHP62-CYTDprior", ",") ' Uncomment and fix if needed
    
    Set wb1 = ActiveWorkbook '收支汇总工作簿
    
    '*****************************打开CYTD文件
    my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create CYTD Reports")
    If my_Filename = False Then Exit Sub ' Removed extra End If
    
    Application.ScreenUpdating = False
    Set wb2 = Workbooks.Open(my_Filename)
    
    '*****************************加载列头字符串并复制数据
    For Each sht In SheetNames
        lastcol = wb1.Sheets(sht).Cells(5, Columns.Count).End(xlToLeft).Column
        
        On Error Resume Next
        Set tabNames = wb1.Sheets(sht).Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants) '第4行从C列到lastCol列的实际非公式文本值
        On Error GoTo 0 ' Moved after error check
        
        If tabNames Is Nothing Then
            MsgBox "No headers were found on row 4 of " & sht, vbCritical ' Updated to show current sheet
            Exit Sub
        End If
        
        For Each cell In tabNames
            tabName = Strings.Trim(cell.Value2) '专用变量，以备后续解析需求（去除空格/逗号等）
            ' Check if target sheet exists
            Dim targetSheet As Worksheet
            On Error Resume Next
            Set targetSheet = wb2.Sheets(tabName)
            On Error GoTo 0
            
            If Not targetSheet Is Nothing Then
                For i = 0 To UBound(addresses)
                    targetSheet.Range(addresses(i)).Value2 = wb1.Sheets(sht).Range(addresses(i)).Offset(0, cell.Column - 1).Value2
                    Debug.Print "data for " & targetSheet.Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets(sht).Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
                Next i
            Else
                Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
            End If
        Next cell
    Next sht
    
    MsgBox "CYTD Report Creation Complete", vbOKOnly
    Application.ScreenUpdating = True
End Sub

内容的提问来源于stack exchange，提问作者smrmodel78