是否可以从多个工作簿中的特定位置提取数据并将其粘贴到单个工作表中的特定位置？

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
...

等等。