下标越界

jaxxcyh

ddz79101 发表于 2024-8-29 15:17
谢谢老师！我想导入的数据簿中3个表，在收集簿中仍是3个表，不需合并1表。可以再帮忙修改吗？谢谢

你的“数据”工作簿中的sheet表除了“目录”、“说明”外，还有“1”，“2”，“3”，“4”个表，你的意思是将后面的4张表转移到“收集”工作簿中？
可你一直在说，“我想导入的数据簿中3个表，在收集簿中仍是3个表”，这不让人搞不懂了吗？你到底是要转移1-4四张表的数据，还是只转移2-4三张表的数据？
有时候表达不清楚，会让人无所适从。
你的源程序中出错的是 sh = wb.Sheets(Array("1", "2", "3", "4")) 这一句，看这样子，似乎想要把四张表的数据弄到“收集”工作簿里，但这么写代码肯定会出错，原因有二：1.给对象类型变量赋值，前面必须加set命令。2. sh是工作表类型变量，每次只能赋值一张工作表，而不能是工作表集合。
给你修改了一下程序，请参考。

1. Option Explicit
   
2. 
   
3. Sub Macro1()
   
4.     Dim MyFile, wb As Workbook, i%
   
5.     Dim sh As Worksheet
   
6.     MyFile = Application.GetOpenFilename(fileFilter:="Excel文件(*.xls),*.xls", Title:="选择Excel文件")
   
7.     If TypeName(MyFile) = "Boolean" Then Exit Sub
   
8.     Cells.Clear
   
9.     If MyFile = ThisWorkbook.FullName Then
   
10.         MsgBox "不能选择本工作簿，请重新选择！", vbInformation
    
11.         Exit Sub
    
12.     End If
    
13.     Set wb = GetObject(MyFile)
    
14.    
    
15.     For i = 1 To wb.Sheets.Count      '按照索引号遍历所有工作表
    
16.         Set sh = wb.Sheets(i)         '获取工作表对象
    
17.         If IsNumeric(sh.Name) Then    '检查工作表名字是否是纯数字
    
18.             'wb.Sheets(i).Copy after:=ThisWorkbook.ActiveSheet    '拷贝到当前工作簿
    
19.             '如果要放在当前工作簿所有工作表的末尾，那就换成下面的代码(同时把上面一句注释掉或删除)
    
20.             wb.Sheets(i).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
21.         End If
    
22.     Next
    
23.     wb.Close True
    
24.     MsgBox "ok"
    
25. End Sub
    
26. 
    
27. 
    

复制代码

gwjkkkkk

gwjkkkkk 发表于 2024-8-29 22:26
。。。。。。。。。。。

Option Explicit
Option Compare Text
Sub test()
    Dim ar, i&, vFile, Filter$, strJoin$, wks As Worksheet, wks1 As Sheets
   
    Application.DefaultFilePath = ThisWorkbook.Path & "\"
    Filter = "Excel Files(*.xls*), * .xls* "
    vFile = Application.GetOpenFilename(Filter, 3, "请选择文件", , False)
    If vFile = False Then Exit Sub
   
    If FileName(vFile) = ThisWorkbook.Name Then
        MsgBox "不能选择与本工作簿相同文件名的工作簿！", vbCritical
        Exit Sub
    End If
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    ar = Array("1", "2", "3", "4")
    strJoin = "," & Join(ar, ",") & ","
   
    For Each wks In Worksheets
        If InStr(strJoin, "," & wks.Name & ",") Then wks.Delete
    Next
    With GetObject(vFile)
        Set wks1 = .Worksheets(ar)
        wks1.Copy after:=Worksheets(Worksheets.Count)
        .Close False
    End With
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub
Function FileName(FullName As Variant) As String
    Application.Volatile
    FileName = Right(FullName, Len(FullName) - InStrRev(FullName, "\"))
End Function

gwjkkkkk

ddz79101 发表于 2024-8-29 23:11
谢谢老师！你的代码将导入的3个工作表合并到1个工作表中了，我要原样，仍分为3个工作表。可以帮忙修改吗?

................

ddz79101

gwjkkkkk 发表于 2024-8-30 20:31
................

谢谢老师！如愿成功

ddz79101

jaxxcyh 发表于 2024-8-30 00:22
你的“数据”工作簿中的sheet表除了“目录”、“说明”外，还有“1”，“2”，“3”，“4”个表，你的意 ...

谢谢老师！你的指点非常详细。正如你所说，关键是我对wb.Sheets(Array("1", "2", "3", "4"))的理解有误。你的代码正是我想需要的，运行成功。谢谢！

ddz79101

王渐明 发表于 2024-8-29 13:50
Option Explicit

Sub Macro1()

谢谢老师！运行顺利