在文件路徑中打開工作簿並將工作表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腳本運行時引用添加到您的項目。 你可以在這里閱讀更多