Excel 有人能为代码重构提供帮助吗

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

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

Sub-AllFiles（）
将folderPath设置为字符串
将文件名设置为字符串
将wb设置为工作簿
folderPath=“C:\Users\enchevay\Desktop\automation\WeeklyReports\”
如果正确（folderPath，1）“\”则folderPath=folderPath+“\”
filename=Dir（folderPath&“*.xlsx”）
文件名“”时执行此操作
Application.ScreenUpdating=False
'复制并粘贴pm
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“F18”）。副本
emptyRow=Sheet1.单元格（Rows.Count，1）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，1），单元格（emptyRow，19））
'复制粘贴客户端
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“F14”）。副本
emptyRow=Sheet1.单元格（Rows.Count，2）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，2），单元格（emptyRow，19））
'复制粘贴项目
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“F16”）。副本
emptyRow=Sheet1.单元格（Rows.Count，3）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，3），单元格（emptyRow，19））
'复制并粘贴项目类型
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“F20”）。复制
emptyRow=Sheet1.单元格（Rows.Count，4）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，4），单元格（emptyRow，19））
'复制粘贴项目阶段
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“L20”）。副本
emptyRow=Sheet1.单元格（Rows.Count，5）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，5），单元格（emptyRow，19））
'复制并粘贴预算
'范围（“”）。复制
'复制和粘贴结束日期
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“U18”）。副本
emptyRow=Sheet1.单元格（Rows.Count，7）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，7），单元格（emptyRow，19））
'复制并粘贴PM整体
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“AB15”）。副本
emptyRow=Sheet1.单元格（Rows.Count，8）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，8），单元格（emptyRow，19））
'复制并粘贴总体计算
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“AF15”）。副本
emptyRow=Sheet1.单元格（Rows.Count，9）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，9），单元格（emptyRow，19））
'复制并粘贴财务报表
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“AK15”）。副本
emptyRow=Sheet1.单元格（Rows.Count，10）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，10），单元格（emptyRow，19））
'复制粘贴客户端
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“AM15”）。副本
emptyRow=Sheet1.单元格（Rows.Count，11）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，11），单元格（emptyRow，19））
'复制粘贴解决方案
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“AO15”）。副本
emptyRow=Sheet1.单元格（Rows.Count，12）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，12），单元格（emptyRow，19））
'复制和粘贴计划
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“AQ15”）。副本
emptyRow=Sheet1.单元格（Rows.Count，13）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，13），单元格（emptyRow，19））
'复制和粘贴可交付成果
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“AS15”）。副本
emptyRow=Sheet1.单元格（Rows.Count，14）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，14），单元格（emptyRow，19））
'复制和粘贴资源
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“AK18”）。副本
emptyRow=Sheet1.单元格（Rows.Count，15）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，15），单元格（emptyRow，19））
'复制和粘贴问题
设置wb=Workbooks.Open（文件夹路径和文件名）
范围（“AM18”）。副本
emptyRow=Sheet1.单元格（Rows.Count，16）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，16），单元格（emptyRow，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