是否可以從多個工作簿中的特定位置提取數據並將其粘貼到單個工作表中的特定位置？

Question

我正在嘗試從數千個更改文件名的 Excel 工作簿中提取數據。 目標是讓宏遍歷我文件夾中的每個工作簿並提取特定數據並將其粘貼到單個工作表中。

我知道一個循環是必要的。 到目前為止，這就是我所擁有的，但它沒有正確執行。 宏運行但沒有任何反應。 有人可以幫我解決這個問題嗎？

Sub WBsInFolderToMaster()

Dim Sheet2 As Worksheet
Set Sheet2 = ThisWorkbook.Worksheets("Sheet2")

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.Calculation = xlCalculationManual

On Error Resume Next

Dim X As Long
    For X = 6 To 8
        If Sheet2.Cells(X, "E").Value2 <> "" Then
   
            Dim FPath As Long
            FPath = Sheet2.Cells(X, "F").Value
       
            Dim openwb1 As Workbook
            Set openwb1 = Workbooks.Open(FPath, UpdateLinks:=False)
       
            Dim SPtab As Worksheet
            Set SPtab = openwb1.Sheets("SUMMARY PAGE")

            Dim PItab As Worksheet
            Set PItab = openwb1.Sheets("PROJECT INFORMATION")

            Dim CDtab As Worksheet
            Set CDtab = openwb1.Sheets("COST_DETAIL")

            Dim CStab As Worksheet
            Set CStab = openwb1.Sheets("COST_SUMMARY")
               
            '----------------------------------------------------------------------
            'SUMMARY PAGE TAB

            'Unprotect workbook
            openwb1.Unprotect Password:="PASSWORD"
           
            'Unprotect sheet
            SPtab.Unprotect Password:="PASSWORD"

            'Copy and Paste Disaster
            SPtab.Range("C8").Copy = Sheet2.Cells(X, "G").PasteSpecial(xlPasteValues)

            'Copy and Paste PW
            SPtab.Range("E7").Copy = Sheet2.Cells(X, "H").PasteSpecial(xlPasteValues)

            'Copy and Paste Applicant
            SPtab.Range("C3").Copy = Sheet2.Cells(X, "I").PasteSpecial(xlPasteValues)

            'Copy and Paste Program
            SPtab.Range("C7").Copy = Sheet2.Cells(X, "J").PasteSpecial(xlPasteValues)

            'Copy and Paste RFR
            SPtab.Range("E8").Copy = Sheet2.Cells(X, "K").PasteSpecial(xlPasteValues)
           
            '----------------------------------------------------------------------
            'PROJECT INFORMATION TAB
           
            'Unprotect sheet
            PItab.Unprotect Password:="Password"

            'Copy and Paste Disaster
            PItab.Range("C8").Copy = Sheet2.Cells(X, "L").PasteSpecial(xlPasteValues)

            'Copy and Paste PW
            PItab.Range("E7").Copy = Sheet2.Cells(X, "M").PasteSpecial(xlPasteValues)
           
            'Copy and Paste Applicant
            PItab.Range("C3").Copy = Sheet2.Cells(X, "N").PasteSpecial(xlPasteValues)

            'Copy and Paste Program
            PItab.Range("C7").Copy = Sheet2.Cells(X, "O").PasteSpecial(xlPasteValues)

            'Copy and Paste RFR
            PItab.Range("E8").Copy = Sheet2.Cells(X, "P").PasteSpecial(xlPasteValues)
   
            '----------------------------------------------------------------------
            'COST_DETAIL TAB
           
            'Unprotect sheet
            CDtab.Unprotect Password:="PASSWORD"

            'Copy and Paste SUBRECIPIENT
            CDtab.Range("D2").Copy = Sheet2.Cells(X, "Q").PasteSpecial(xlPasteValues)

            'Copy and Paste ELIGIBLE AMOUNT
            CDtab.Range("O5").Copy = Sheet2.Cells(X, "R").PasteSpecial(xlPasteValues)

            'Copy and Paste SUBSTANTIATED AMOUNT
            CDtab.Range("X6").Copy = Sheet2.Range(X, "S").PasteSpecial(xlPasteValues)
           
            '----------------------------------------------------------------------
            'COST SUMMARY TAB
           
            'Unprotect sheet
            CStab.Unprotect Password:="PASSWORD"

            'Copy and Paste SUBRECIPIENT
            CStab.Range("C2").Copy = Sheet2.Cells(X, "T").PasteSpecial(xlPasteValues)

            'Copy and Paste SUBSTANTIATED AMOUNT
            CStab.Range("X6").Copy = Sheet2.Cells(X, "U").PasteSpecial(xlPasteValues)
           
            '----------------------------------------------------------------------
            'CLOSING WORKBOOK

            openwb1.Close (False)
        End If
    Next X

'----------------------------------------------------------------------
'WHEN LOOP IS COMPLETE

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.Calculation = xlCalculationAutomatic

ThisWorkbook.Save

End Sub

Answer 1

1. 刪除On Error Resume Next 。 那只是隱藏了所有錯誤。
2. Dim FPath As Long應該是Dim FPath As String 。
3. 您不能在一行中Copy和PasteSpecial 。 它必須是兩個獨立的步驟，但是......
4. 通過使用值轉移來避免剪貼板會更好，例如：

SPtab.Range("C8").Copy = Sheet2.Cells(X, "G").PasteSpecial(xlPasteValues)
...
SPtab.Range("E7").Copy = Sheet2.Cells(X, "H").PasteSpecial(xlPasteValues)
...

變得

Sheet2.Cells(X, "G").Value = SPtab.Range("C8").Value
...
Sheet2.Cells(X, "H").Value = SPtab.Range("E7").Value
...

等等。