跨簿的复制内容

gwjkkkkk

Option Explicit
Sub TEST()
    Dim strFileName$, strPath$, i&, Rng As Range, rngTarget As Range
   
    Application.ScreenUpdating = False
    strPath = ThisWorkbook.Path & "\"
    Set rngTarget = [A1].CurrentRegion
   
    strFileName = Dir(strPath & "*.xls*")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
           With Workbooks.Open(strPath & strFileName)
              Set Rng = Nothing
              For i = 1 To Len(FName(strFileName))
                 If Rng Is Nothing Then
                    Set Rng = rngTarget.Columns(Val(Mid(FName(strFileName), i, 1)) + 1)
                 Else
                    Set Rng = Union(Rng, rngTarget.Columns(Val(Mid(FName(strFileName), i, 1)) + 1))
                 End If
              Next i
              Rng.Copy .Sheets(1).[B1]
              .Close True
           End With
        End If
        strFileName = Dir
    Loop
   
    Application.ScreenUpdating = True
    Beep
End Sub
Function FName(FileName As Variant) As String
   Application.Volatile
   FName = Left(FileName, InStrRev(FileName, ".") - 1)
End Function

gwjkkkkk

请参考。。。

LVMJ2023

3190496160 发表于 2023-2-7 15:10

老师，没效果耶

LVMJ2023

7176386 发表于 2023-2-7 14:13
'文档打开自定义函数

可以在这个函数这里，读取到文件后，把数据用数组存起来

我懂了  用函数 等于那个簿的相对单元格就行了  谢谢

7176386

LVMJ2023 发表于 2023-2-7 18:24
我懂了  用函数 等于那个簿的相对单元格就行了  谢谢

是的，要尝试着写，以后方便很多。

3190496160

LVMJ2023 发表于 2023-2-7 18:12
老师，没效果耶

呵呵，什么意思呀？没认真测试吧
我测试是对的呀，你把原来的数据删除再测试就知道了啊

LVMJ2023

3190496160 发表于 2023-2-7 19:21
呵呵，什么意思呀？没认真测试吧
我测试是对的呀，你把原来的数据删除再测试就知道了啊

好的  我再试下  谢谢老师

LVMJ2023

3190496160 发表于 2023-2-7 19:21
呵呵，什么意思呀？没认真测试吧
我测试是对的呀，你把原来的数据删除再测试就知道了啊

不好意思，再试了下，可以的，但有一个问题，那些表会自动关闭

LVMJ2023

gwjkkkkk 发表于 2023-2-7 15:36
请参考。。。

谢谢老师，按了按钮后有些表会自动关闭

gwjkkkkk

LVMJ2023 发表于 2023-2-8 12:10
谢谢老师，按了按钮后有些表会自动关闭

是这样吗？，只要改一句代码就行,已备注。。。