在文件路径中打开工作簿并将工作表2复制到Masterworkbook

Question

我想在硬盘驱动器的文件filepath打开所有工作簿，然后将表数据从工作表2复制到名称为Master的Master工作簿中。

我找到了这段代码，并对其进行了修改以满足自己的需要，但我遇到了麻烦。

Sub LoopThroughDirectory()

Dim MyFile As String
Dim erow
Dim Filepath As String

Filepath = "C:\home\Se\058 \dxakmh\Desktop\TestMiljö\Prognosverktyg\Sektionsfil\Gruppfiler"

MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
    If MyFile = “master.xlsm” Then
        Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Worksheets("FärdigÖnskemål").Range("A4:D4").Select
    ActiveWorkbook.Close

    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Paste Destination:=Worksheets("DataÖnskemål").Range(Cells(erow, 1), Cells(erow, 4))

    MyFile = Dir
Loop

End Sub

这个星期五有什么帮助吗？

Answer 1

根据您的代码，不清楚Worksheet是目标表（要粘贴到的Worksheets("DataÖnskemål") ），是Worksheets("DataÖnskemål") Sheet1还是Worksheets("DataÖnskemål") 。

无论如何，在我的代码中它将粘贴到Sheet1 ，让我知道您是否还有其他意思。

码

Option Explicit

Sub LoopThroughDirectory()

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

Filepath = "C:\home\Se\058 \dxakmh\Desktop\TestMilj?\Prognosverktyg\Sektionsfil\Gruppfiler\"

MyFile = Dir(Filepath)
Do While MyFile <> ""
    If Not MyFile Like "master.xlsm" Then
        Set wb = Workbooks.Open(Filepath & MyFile)

        erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        wb.Worksheets("DataÖnskemål").Range("A4:D4").Copy Destination:=Sheet1.Range("A" & erow)

        wb.Close False
    End If
    MyFile = Dir()
Loop

End Sub

Answer 2

我建议改用FileSystemObject：

Sub LoopThroughDirectory()

Dim MyFile As File
Dim erow As Long
Dim Filepath As String
Dim wb As Workbook
Dim FSO As New Scripting.FileSystemObject

Filepath = "C:\home\Se\058 \dxakmh\Desktop\TestMilj?\Prognosverktyg\Sektionsfil\Gruppfiler"

For Each MyFile In FSO.GetFolder(Filepath).Files
    If Not MyFile.Name Like "master.xlsm" Then
        Debug.Print MyFile.Path
        Set wb = Workbooks.Open(MyFile.Path)

        erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        wb.Worksheets("DataÖnskemal").Range("A4:D4").Copy Destination:=Sheet1.Range("A" & erow)

        wb.Close False
    End If
Next

End Sub

您必须将Microsoft脚本运行时引用添加到您的项目。 你可以在这里阅读更多