How to select multiple worksheets and copy to desktop folder
Category: [Excel] Demo Available
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
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.
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| How to create VBA to save reports, generated using macros to specific folders |
| How to search in subfolders and word documents |
| How to use VBA script to count files/subfolders using a range from WB for the root folder |
| How to list & display all files in user folder, select file and copy specific tab into master sheet |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.