Macro to save copied data

Hi,

The below macro basically copies a work sheet, opens a work book, pastes the copied data, closes the work sheet it just copied and then saves and closed the work book, then it reopens and repeats.

When it saves and closes and reopens the workbook it takes a long time.

Is there a way for it to only save and close the workbook once all the open work sheets to copied and pasted are completed?

Sub Mega_Dump()

Dim wbTarget As Workbook    'workbook where the data is to be pasted
Dim wbThis As Workbook      'workbook from where the data is to copied
Dim strName As String       'target workbook
Dim cn As String
Dim shName As String
Dim wasOPEN As Boolean

    
shName = Range("D6").Value
    
Set wbThis = ActiveWorkbook                                     'set to the current active workbook (the source book)
   
On Error Resume Next
Set wbTarget = Workbooks("My FILE PATH")           'try to find already open workbook

If Not wbTarget Is Nothing Then
    wasOPEN = True                                              'make a note that it was already open
Else                                                            'open it if it was closed, put your path in the space noted
    Set wbTarget = Workbooks.Open("My FILE PATH")
End If
      
wbTarget.Sheets(shName).Range("xfd1").EntireColumn.ClearContents  'select cell A1 on the target book
wbThis.Activate                                                 'activate the source book
Application.CutCopyMode = False                                 'clear any thing on clipboard to maximize available memory
  
wbThis.ActiveSheet.Range("b2:af44").Copy                         'copy the range from source book
                                                                'paste the data on the target book ( for just values PasteSpecial xlValues )
wbTarget.Sheets(shName).Cells(2, Columns.Count).End(xlToLeft).Offset(, 6).PasteSpecial xlPasteAll
 
Application.CutCopyMode = False                                 'clear any thing on clipboard to maximize available memory

If wasOPEN Then wbTarget.Save Else wbTarget.Close True          'save the target book, close it if it was closed before
 
wbThis.Close                                              'activate or close the source book again

Set wbTarget = Nothing                                          'clear memory
Set wbThis = Nothing

   Application.OnTime Now + TimeValue("00:00:01"), "Mega_Dump"
End Sub

Following code will open a folder to pick where all your workbooks (To Copy Data From ) are saved and then will copy them to the current workbook.

Sub FoldPick()
    Dim FDiag As FileDialog
    Dim Paths
    Dim FName
    Dim WB As Workbook
    Dim LastRow
    Dim ThisWBLAstRow
    Set FDiag = Application.FileDialog(msoFileDialogFolderPicker)
    FDiag.AllowMultiSelect = False
    FDiag.Title = "Select the Folder which has the Files"
    FDiag.Show
    Paths = FDiag.SelectedItems(1)
    FName = Dir(Paths & "\*.csv")
    With ThisWorkbook.Worksheets(2)
        .Range("A1") = "Date"
        .Range("B1") = "Employee Name"
        .Range("C1") = "Login Time"
        .Range("D1") = "Logout Time"
        .Range("E1") = "Total System Time"
    End With
    Application.DisplayAlerts = False
    Do Until Len(FName) = 0
        Workbooks.Open (Paths & "\" & FName)
        Set WB = Workbooks(FName)
        With WB
            LastRow = .Worksheets(1).Range("A65536").End(xlUp).Row
            ThisWBLAstRow = ThisWorkbook.Worksheets(2).Range("A65536").End(xlUp).Row
            .Worksheets(1).Range("A2:E" & LastRow).Copy
            ThisWorkbook.Worksheets(2).Range("A" & ThisWBLAstRow + 1).PasteSpecial xlPasteValues
            .Close No
        End With
        FName = Dir
    Loop
   
    ThisWorkbook.Close Yes
    Application.DisplayAlerts = True
End Sub

Let me know if it helps.
Cheers