其它工作表SHEET1整表导入

banditson

TEST.rar (234.05 KB, 下载次数: 40)

2018-7-19 10:59 上传

点击文件名下载附件

如上附件，把基础数据中对应文件中SHEET1导入到TEST文件---对应表名的工作表中，整表覆盖，我已经写了提取代码但就是导不过来，请大神帮我看一下代码，谢谢！！！！

lsc900707

Sub TEST()

Application.ScreenUpdating = False

Set d = CreateObject("scripting.dictionary")

MyPath = ThisWorkbook.Path & "\基础数据\"

MyName = Dir(MyPath & "*.xlsx")

Do While MyName <> ""

If MyName <> ThisWorkbook.Name Then

Set wb = GetObject(MyPath &  MyName)

For Each sh In Sheets

If sh.Name = Split(MyName,  ".")(0) Then wb.Sheets(1).Cells.Copy sh.[a1]

Next

wb.Close False

End If

MyName = Dir

Loop

Application.ScreenUpdating = True

MsgBox "文件夹内所有数据已导入！"

End Sub

lsc900707

1. Sub TEST()
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     MyPath = ThisWorkbook.Path & "\基础数据"
   
5.     MyName = Dir(MyPath & "*.xlsx")
   
6.     Do While MyName <> ""
   
7.         If MyName <> ThisWorkbook.Name Then
   
8.             Set wb = GetObject(MyPath & MyName)
   
9.             For Each sh In Sheets
   
10.                 If sh.Name = Split(MyName, ".")(0) Then wb.Sheets(1).Cells.Copy sh.[a1]
    
11.             Next
    
12.             wb.Close False
    
13.         End If
    
14.         MyName = Dir
    
15.     Loop
    
16.     Application.ScreenUpdating = True
    
17.     MsgBox "文件夹内所有数据已导入！"
    
18. End Sub
    

复制代码

lsc900707

附件供测试参考：

banditson

lsc900707 发表于 2018-7-19 11:21

谢谢版主大人，我发现下面3行删除似乎没影响，请问这样删除有什么问题吗？
Sub TEST()
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")‘不使用字典，此行可省略
    MyPath = ThisWorkbook.Path & "\基础数据\"
    MyName = Dir(MyPath & "*.xlsx")
    On Error Resume Next
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then‘主表和数据表不在同文件夹，此行可省略
            With GetObject(MyPath & MyName).Sheets(1)'直接针对表1取数
                For Each sh In Sheets
                    If sh.Name = Split(MyName, ".")(0) Then .Cells.Copy sh.[a1]’换为Split取数
                Next
                .Close False
            End With
        End If‘此行可省略
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "文件夹内所有数据已导入！"
End Sub

lsc900707

banditson 发表于 2018-7-19 13:28
谢谢版主大人，我发现下面3行删除似乎没影响，请问这样删除有什么问题吗？
Sub TEST()
    Application ...

你去掉On Error Resume Next 试试就知道。

banditson

lsc900707 发表于 2018-7-19 14:36
你去掉On Error Resume Next 试试就知道。

运行到.Close False显示“对象不支持该属性或方法”，加上On Error Resume Next就可通过，但VBA后台中，基础数据的各个表还在（EXCEL窗口中没显示），需要手动打开该表再手动关闭，VBA工程中对应文件才没有，应该还是出在.Close False上，因为上面WITH引用的是工作簿中的工作表而不是工作簿本身，不知是不是这个问题，如果是的话.Close False应该怎么改呢？？？

banditson

lsc900707 发表于 2018-7-19 14:36
你去掉On Error Resume Next 试试就知道。

版主，我按我7楼的思路去尝试改回原来的GetObject(MyPath & MyName)取工作簿后.Close False可用不报错，代码精简如下。不断反馈问题加改善，EXCELHOME真的让我受益良多，谢谢！
Sub TEST1()
    Application.ScreenUpdating = False
   ' Set d = CreateObject("scripting.dictionary")，此行精简
    MyPath = ThisWorkbook.Path & "\基础数据\"
    MyName = Dir(MyPath & "*.xlsx")
    'On Error Resume Next
    Do While MyName <> ""
        'If MyName <> ThisWorkbook.Name Then，此行精简
            With GetObject(MyPath & MyName)
                For Each sh In Sheets
                    If sh.Name = Split(MyName, ".")(0) Then .Sheets(1).Cells.Copy sh.[a1]
                Next
               .Close False
            End With
       'End If，此行精简
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "导入完成！"
End Sub

lsc900707

banditson 发表于 2018-7-20 13:19
版主，我按我7楼的思路去尝试改回原来的GetObject(MyPath & MyName)取工作簿后.Close False可用不报错， ...

学会给人“评分”，你学到的东西会更多的。呵呵。