Question

目标 - 从多个工作簿中提取数据（共5个）;将数据粘贴到新工作簿中。

问题/问题：
1）运行以下VBA代码后，它可以复制所有5个工作簿中的数据，但只粘贴其中一个工作簿的粘贴数据。
2）剪贴板的弹出窗口已满。我已经编写了一个代码来清除剪贴板，但它似乎没有起作用，因为我仍然得到弹出窗口。

VBA代码：

Sub LoopThroughDirectory()

Dim MyFile As String
Dim erow

Dim MyPath As String

MyPath = "Directory path"

MyFile = Dir(MyPath)

Do While Len(MyFile) > 0
If MyFile = "filename.xlsb" Then
End If

       Workbooks.Open (MyPath & MyFile)
       Range("A3:CP10000").Copy
       ActiveWorkbook.Close

'calculating the empty row

 erow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 

a = ActiveWorkbook.Name
b = ActiveSheet.Name

Worksheets("Raw Data").Paste Range("A2")

Application.CutCopyMode = False ' for clearing clipboard

MyFile = Dir

Loop

End Sub

我也在下面尝试了其他两个命令，但它们似乎根本没有返回任何数据。

ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow + 1, 1), Cells(erow + 1, 30)) `pasting the data`
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range("A2")`pasting the data`

更新
这是当前的代码：

Sub LoopThroughDirectory()

Dim MyFile As String
Dim erow As Long
Dim MyPath As String
Dim wb As Workbook

MyPath = "C:\Users\username\Downloads\PROJECTS\Project Name\Input file\"
MyFile = Dir(MyPath)

Do While Len(MyFile) > 0
    If InStr(MyFile, "post_level.xlsb") > 0 Then

        Set wb = Workbooks.Open(MyPath & MyFile)
        Range("A3:CP10000").Copy

        'calculating the empty row
         erow = ThisWorkbook.Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlUp).Row

        ThisWorkbook.Worksheets("Raw Data").Paste (ThisWorkbook.Worksheets("Raw Data").Range("A" & erow + 2))

        Application.DisplayAlerts = False
        wb.Close False
        Application.DisplayAlerts = True
    End If
    MyFile = Dir
Loop

    ActiveWindow.Zoom = 90

End Sub

Update2。

Sub LoopThroughDirectory()

Dim MyFile As String
Dim erow As Long
Dim MyPath As String
Dim wb As Workbook

MyPath = "C:\Users\username\Downloads\PROJECTS\ProjectNameFolder\SubFolder\MainFolder\Input file"
MyFile = Dir("C:\Users\username\Downloads\PROJECTS\ProjectNameFolder\SubFolder\MainFolder\Input file\*.*")

Do While Len(MyFile) > 0
    If InStr(MyFile, ".csv") > 0 Then

        Set wb = Workbooks.Open(MyPath & MyFile)
        Range("A3:CP10000").Copy

        'calculating the empty row
         erow = ThisWorkbook.Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlUp).Row

        ThisWorkbook.Worksheets("Raw Data").Paste (ThisWorkbook.Worksheets("Raw Data").Range("A" & erow + 2))

        Application.DisplayAlerts = False
        wb.Close False
        Application.DisplayAlerts = True
    End If
    MyFile = Dir
Loop

End Sub

Answer 1

我希望我能提供帮助......您的代码中存在多个错误，我不确定是否以您希望的方式修复它们。

提一个主要错误是有用的。你不能将这两行放在一起：

If MyFile = "filename.xlsb" Then
End If

在这些行之间，如果满足If条件，则必须放置要执行的每个过程。在原始情况下，如果有一个名为＆＃34; filename.xlsb＆＃34;的文件，则不会发生任何事情，因为您立即关闭了代码块...

尝试类似于以下代码的内容。我可以从C:\Temp\目录中的所有文件导入数据，这些文件的扩展名为.xlsb

Sub LoopThroughDirectory()

Dim MyFile As String
Dim erow As Long
Dim MyPath As String
Dim wb As Workbook

MyPath = "C:\Temp\"
MyFile = Dir(MyPath)

Do While Len(MyFile) > 0
    If InStr(MyFile, ".xlsb") > 0 Then

        Set wb = Workbooks.Open(MyPath & MyFile)
        Range("A3:CP10000").Copy

        'calculating the empty row
         erow = ThisWorkbook.Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlUp).Row

        ThisWorkbook.Worksheets("Raw Data").Paste (ThisWorkbook.Worksheets("Raw Data").Range("A" & erow + 2))

        Application.DisplayAlerts = False
        wb.Close False
        Application.DisplayAlerts = True
    End If
    MyFile = Dir
Loop

End Sub

从多个工作簿传输数据

1 个答案: