VBA提取当前文件夹内所有excel的制定数据

ytui676

朱荣兴 发表于 2018-9-15 10:56
附件是空的，请重新上传

已在1楼更新

ytui676

longming3 发表于 2018-9-15 10:52
压缩包有问题，不能解压

已在1楼更新

longming3

附件也是扯淡，至少要把你需要导入的数据放几个在一个命名的文件夹里面，什么都没有。根据你的描述，大概写了个。有代码的表格要保存为xls或xlsm格式。
Sub dr()
    Dim ar, myPath$, myName$, Myr&
    Application.ScreenUpdating = False
    myPath = ThisWorkbook.Path & "\提取" '“提取”改成你自己要提取数据的文件夹名
    myName = Dir(myPath & "*.xls*") '
    With ThisWorkbook.Sheets("提取数据")
        Do While myName <> ""
            Set wb = GetObject(myPath & myName)
            m = wb.ActiveSheet.[a65536].End(3).Row
            If m > 9 Then
                For i = 10 To m
                    If wb.ActiveSheet.Range("d" & i) <> "" Then
                        wb.ActiveSheet.Range("a" & i & ":ac" & i).Copy .Range("a" & [a65536].End(3).Row + 1)
                    End If
                Next
            End If
            wb.Close False
            myName = Dir
        Loop
    End With
    Application.ScreenUpdating = True
End Sub