How to Select multiple worksheets and copy to desktop folder

How to select multiple worksheets and copy to desktop folder

Requirement:

The user is using a macro enabled work book to process a number of files and have them in a desktop folder together with the result.

The user is trying to do the following:

1 User selects one or more.csv files and clicks “Copy”

2 Macro creates new desktop folder using

MkDir "C:\Users" & Environ("UserName") & "\Desktop\Matches" & " " & Format (Now (), "DD-MMM-YYYY hh mm ss")

(Time format so there will never be an issue with the folder already existing)

3 Macro pastes copies of selected files intact into newly created folder.

4 Macro takes Sheet2 of each from row 2** and combines them into new sheet "Matches.csv", which is then opened.

**(So headers are lost. This is because the user is sure there is a way of merging them using the headers from the first sheet but I does not know how to do this, so has 'cheated' and get the macro to populate the headers afterwards).

From that point on the user knows what they are doing and can run the macro over the sheet and save the resulting summary alongside the sheets that have been summarised. The user has pieced together the code below which works in conjunction with the rest of my macro, but of course does everything within the macro enabled workbook.

Code:

Dim CurrentBook As Workbook
Dim info As String
info = "UserForm 1 Matches"

Dim lastrow As Long
Dim length As Integer
Dim MyFileName As Variant
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("Sheet2")
Dim IndvFiles As FileDialog
Dim FileIdx As Long
Dim i As Integer, x As Integer
Dim r As Range
Dim Sheet As Variant
Set IndvFiles = Application.FileDialog(msoFileDialogOpen)
With IndvFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add ".csv files", "*.csv"
    .Show
End With

Application.DisplayAlerts = False
Application.ScreenUpdating = False

For FileIdx = 1 To IndvFiles.SelectedItems.Count
    Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx))
    For Each Sheet In CurrentBook.Sheets
        Dim LRow1 As Long
        LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
        Dim LRow2 As Long
        LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row

        Dim ImportRange As Range
        Set ImportRange = CurrentBook.ActiveSheet.Range("A2:Z" & LRow2)
        ImportRange.Copy
        WS.Range("A" & LRow1 + 1).PasteSpecial 'Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Next
    CurrentBook.Close False
Next FileIdx

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1213988-select-multiple-worksheets-and-copy-to-desktop-folder

Solution:

See if this macro does steps 1 to 4, as required. Rather than opening each selected .csv file, it uses a text query to import the data into the macro workbook. The first .csv file import starts at row 1, to include column headings, and subsequent files start at row 2 to omit them. I put comments in the code to help you to understand it.

Code:

Public Sub Copy_and_Import_Selected_CSV_Files()

    Dim destinationFolder As String
    Dim destinationCell As Range
    Dim startRow As Long
    Dim FD As FileDialog
    Dim csvFile As Variant
    
    'Set destination folder where .csv files will be copied - a new Desktop subfolder

    destinationFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Matches " & Format(Now, "DD-MMM-YYYY hh mm ss\")

    If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"
    If Dir(destinationFolder, vbDirectory) = vbNullString Then MkDir destinationFolder
    
    'Set destination cell where first .csv file will be imported - A1 in first sheet in this workbook
    
    With ThisWorkbook.Worksheets(1)
        .Cells.Clear
        Set destinationCell = .Range("A1")
    End With
    startRow = 1
    
    'Select multiple .csv files
    
    Set FD = Application.FileDialog(msoFileDialogOpen)
    With FD
        .AllowMultiSelect = True
        .Title = "Multi-select target data files:"
        .ButtonName = ""
        .Filters.Clear
        .Filters.Add ".csv files", "*.csv"
        If Not .Show Then Exit Sub
    End With
  
    'For each .csv file, copy it to destination folder and import data
    
    For Each csvFile In FD.SelectedItems
      
        'Copy .csv file to destination folder
        
        FileCopy csvFile, destinationFolder & Mid(csvFile, InStrRev(csvFile, "\") + 1)
        
        'Import csv data to current destination cell
        
        With destinationCell.Worksheet.QueryTables.Add(Connection:="TEXT;" & csvFile, Destination:=destinationCell)
            .TextFileStartRow = startRow
            .TextFileCommaDelimiter = True
            .Refresh BackgroundQuery:=False
            Set destinationCell = destinationCell.Offset(.ResultRange.Rows.Count, 0)
            .Delete
        End With
        
        'Import next csv data from row 2
        
        startRow = 2
        
    Next
    
    'Save destination sheet as Matches.csv in destination folder
    
    destinationCell.Worksheet.Copy
    ActiveWorkbook.SaveAs Filename:=destinationFolder & "Matches.csv", FileFormat:=xlCSV
    ActiveWorkbook.Close False
    
    'Clear destination sheet in this workbook
    
    destinationCell.Worksheet.Cells.Clear
    
    'Open Matches.csv
    
    Workbooks.Open Filename:=destinationFolder & "Matches.csv"
    
    MsgBox "Finished"
  
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by Carim.