下标越界

ddz79101

有老师帮忙看看吗

romecyf

Option Explicit
Sub Macro1()
    Dim MyFile, sh, wb As Workbook, i%
    MyFile = Application.GetOpenFilename(fileFilter:="Excel文件(*.xls),*.xls", Title:="选择Excel文件")
    If TypeName(MyFile) = "Boolean" Then Exit Sub
    Cells.Clear
    If MyFile = ThisWorkbook.FullName Then
        MsgBox "不能选择本工作簿，请重新选择！", vbInformation
        Exit Sub
    End If
    Set wb = GetObject(MyFile)
    For i = 3 To wb.Sheets.Count
         wb.Sheets(i).UsedRange.Copy ThisWorkbook.Sheets(i - 2).Range("a1")
    Next
    wb.Close True
    MsgBox "ok"
End Sub

gwjkkkkk

ddz79101 发表于 2024-8-29 21:21
有老师帮忙看看吗

Option Explicit
Option Compare Text
Sub test()
    Dim ar, br, cr, i&, j&, k&, r&, vFile, Filter$, iColSize&
   
    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
    ar = Array("1", "2", "3", "4")
    ReDim br(1 To 10 ^ 4, 1 To 10 ^ 3)
   
    With GetObject(vFile)
        For i = 0 To UBound(ar)
            cr = .Worksheets(ar(i)).UsedRange.Value
            For k = 1 To UBound(cr)
                r = r + 1
                For j = 1 To UBound(cr, 2)
                    br(r, j) = cr(k, j)
                Next j
            Next k
            If UBound(cr, 2) > iColSize Then iColSize = UBound(cr, 2)
        Next i
        .Close False
    End With
   
    Cells.Clear
    [A1].Resize(r, iColSize) = br
    Application.ScreenUpdating = 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 21:21
有老师帮忙看看吗

。。。。。。。。。。。

lsc900707

ddz79101 发表于 2024-8-29 20:10
老师！怎么修改喃？

测试参考附件：

ddz79101

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

谢谢老师！你的代码将导入的3个工作表合并到1个工作表中了，我要原样，仍分为3个工作表。可以帮忙修改吗?

ddz79101

lsc900707 发表于 2024-8-29 23:04
测试参考附件：

谢谢老师！运行完美！谢谢

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个工作表。可以帮忙修改吗?

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