任何人都可以帮助代码重构

Question

大家好我想重构那段代码，但到目前为止，我无法想到如何复制和粘贴所有这些单元格，而无需在每次复制单元格时打开和关闭工作簿。

Sub AllFiles()
    Dim folderPath As String
    Dim filename As String
    Dim wb As Workbook

    folderPath = "C:\Users\enchevay\Desktop\automation\WeeklyReports\"

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

    filename = Dir(folderPath & "*.xlsx")
    Do While filename <> ""
      Application.ScreenUpdating = False


       'copy & paste pm
       Set wb = Workbooks.Open(folderPath & filename)
       Range("F18").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 1), Cells(emptyRow, 19))

       'copy & paste client
       Set wb = Workbooks.Open(folderPath & filename)
       Range("F14").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 2), Cells(emptyRow, 19))

       'copy & paste project
       Set wb = Workbooks.Open(folderPath & filename)
       Range("F16").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 3), Cells(emptyRow, 19))

       'copy and paste project type
       Set wb = Workbooks.Open(folderPath & filename)
       Range("F20").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 4), Cells(emptyRow, 19))

       'copy & paste project stage
       Set wb = Workbooks.Open(folderPath & filename)
       Range("L20").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 5), Cells(emptyRow, 19))


       'copy & paste budget
       'Range("").Copy


       'copy & paste end date
       Set wb = Workbooks.Open(folderPath & filename)
       Range("U18").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 7).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 7), Cells(emptyRow, 19))

       'copy & paste PM overall
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AB15").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 8), Cells(emptyRow, 19))

       'copy & paste Overall calc
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AF15").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 9), Cells(emptyRow, 19))


       'copy & paste Financial
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AK15").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 10).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 10), Cells(emptyRow, 19))


       'copy & paste client
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AM15").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 11), Cells(emptyRow, 19))


       'copy & paste solution
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AO15").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 12).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 12), Cells(emptyRow, 19))


       'copy & paste Schedule
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AQ15").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 13).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 13), Cells(emptyRow, 19))


       'copy & paste Deliverable
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AS15").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 14).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 14), Cells(emptyRow, 19))

       ' copy & paste resources
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AK18").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 15).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 15), Cells(emptyRow, 19))

       'copy & paste issues
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AM18").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 16).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 16), Cells(emptyRow, 19))


       'copy & paste risks
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AO18").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 17).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 17), Cells(emptyRow, 19))



       'copy & paste dependencies
       Set wb = Workbooks.Open(folderPath & filename)
       Range("AQ18").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 18).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 18), Cells(emptyRow, 19))

       'copy & paste RAG justification
       Set wb = Workbooks.Open(folderPath & filename)
       Range("B24").Copy
       emptyRow = Sheet1.Cells(Rows.Count, 19).End(xlUp).Offset(1, 0).Row
       Application.DisplayAlerts = False
       ActiveWorkbook.Close
       ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 19), Cells(emptyRow, 19))
       Application.ScreenUpdating = True




        filename = Dir
    Loop
  Application.ScreenUpdating = True
End Sub

Answer 1

只有在粘贴所有值时才能使用循环并关闭工作簿：

Sub AllFiles()
    Dim folderPath As String
    Dim filename As String
    Dim wb As Workbook
    Dim cellAddr As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    folderPath = "C:\Users\enchevay\Desktop\automation\WeeklyReports\"

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

    filename = Dir(folderPath & "*.xlsx")

    cellAddr = Array("F18", "F14", "F16", "F20", "L20", "", "U18", "AB15", _
        "AF15", "AK15", "AM15", "AO15", "AQ15", "AS15", "AK18", "AM18", _
        "AO18", "AQ18", "B24")
    Do While filename <> ""
        'copy & paste RAG justification
        Set wb = Workbooks.Open(folderPath & filename)

        For i = 1 To 19
            If i <> 6 Then                    
                With ThisWorkbook.Worksheets("Sheet1")
                    emptyRow = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0).Row
                    wb.ActiveSheet.Range(cellAddr(i-1)).Copy .Range(.Cells(emptyRow, i), .Cells(emptyRow, 19))
                End With
            End If
        Next

        wb.Close False
        filename = Dir
    Loop
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

顺便说一下，最好将wb.ActiveSheet.更改为wb.Worksheets("SheetName")。