[已解决]导入数据下标越界

zjdh

Sub 数组法()         '二行标题
    Dim s$(), arr$(), a, sh As Worksheet
    Dim f$, i&, j%, m&, k&, n%, r&
    f = ThisWorkbook.Path & "\test2.txt"   '定位文件
    Application.ScreenUpdating = False     '不刷屏
    Application.DisplayAlerts = False      '不提示
    For Each sh In Sheets                  '删除非当前工作表的其他工作表
        If sh.Name <> ActiveSheet.Name Then sh.Delete
    Next
    Application.DisplayAlerts = True
    Cells.ClearContents                   '清除当前工作表数据
    Open f For Input As #1                '打开数据文件
    s = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)   '读取数据到数组
    Close #1                              '关闭数据文件
    r = Rows.Count                        '每页工作表行数
    B = Split(s(0), vbTab)                '提取标题栏1
    C = Split(s(1), vbTab)                '提取标题栏2
    For k = 2 To UBound(s) Step r - 2     '标题行为二行，数据从第三行开始提取，工作表可容纳数据行数减掉二行
        ReDim arr(1 To r, 2)
        n = n + 1                         '工作表计数
        If n > 1 Then Sheets.Add After:=Sheets(Sheets.Count)  '超过一个工作表则添加表格
        m = 0
        For i = k To k + r - 3               '有二行标题，所以-3
            If i > UBound(s) Then Exit For    '若提取完则退出循环
            m = m + 1
            If s(i) <> "" Then                '若有数据则
            a = Split(s(i), vbTab)            '提取一行数据
            For j = 0 To 2                    '赋值一行数据到数组
                arr(m, j) = a(j)
            Next
            End If
        Next
        Range("A1").Resize(1, 3) = B         '填充标题行（一行）
        Range("A2").Resize(1, 3) = C          '填充标题行（一行）
        Range("A3").Resize(m, 3) = arr        '填充数据
    Next
    Application.ScreenUpdating = True
End Sub