First time poster. I've been trying to get more into VBA and some other coding and I am having difficulty with a project I'm working on. I have multiple .CSV files that are holding my data, and I'm trying to merge them all into one master sheet.
When attempting to run the macro, it stops after opening the first .CSV file in the series. It doesn't spit an error out at me, and it just stops running. I'm not sure exactly if I don't have an option enabled for it to complete the merge or what and am looking for any input at all. There's still a good amount of code I have to write with this, such as having it identify specific columns and rows and grab that particular data from each of the sheets, but this is the basis of what I have now. I have this currently setup as a template, I'm not sure if that should be changed? I attempted transferring the code to another fresh workbook and trying it there and it still didn't give me anything.
Option Explicit
Private Sub CommandButton1_Click()
mergeData
End Sub
Sub mergeData()
On Error GoTo ErrHandler
Application.ScreenUpdating = False
' Our FileSystem Objects.
Dim objFs As Object
Dim objFolder As Object
Dim file As Object
'Show a pop up to select a folder.
Dim sPath As String
sPath = chooseFolder()
Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFs.GetFolder(sPath) ' The folder path.
Dim iCnt As Integer
iCnt = 1
' Loop through all the files in the folder.
For Each file In objFolder.Files
Dim objSrc As Workbook ' The source.
Set objSrc = Workbooks.Open(file.Path, True, True)
Dim iTotalRows As Integer ' The total used range in the source file.
iTotalRows = objSrc.Worksheets("Sheet1").UsedRange.Rows.Count
Dim iTotalCols As Integer ' Now, get the total columns in the source.
iTotalCols = objSrc.Worksheets("Sheet1").UsedRange.Columns.Count
Dim iRows, iCols As Integer
' Read data from source and copy in the master file.
For iRows = 1 To iTotalRows
For iCols = 1 To iTotalCols
Application.Workbooks(1).ActiveSheet.Cells(iRows, iCols) = _
objSrc.Worksheets("Sheet1").Cells(iRows, iCols)
' Note: It will read data in "Sheet1" of the source file.
Next iCols
Next iRows
iRows = 0
' Get the name of the file (I'll name the active sheet with the filename).
Dim sSheetName As String
sSheetName = Replace(objSrc.Name, ".csv", "") ' Assuming the files are .xlsx files.
' Close the source file (the file from which its copying the data).
objSrc.Close False
Set objSrc = Nothing
With ActiveWorkbook
.ActiveSheet.Name = sSheetName ' Rename the sheet.
iCnt = iCnt 1
If iCnt > .Worksheets.Count Then
' Create or add a new sheet after the last sheet.
.Sheets.Add After:=.Worksheets(.Worksheets.Count)
End If
.Worksheets(iCnt).Activate ' Go to the next sheet.
End With
Next
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
' Open file dialog box to select a folder.
Function chooseFolder() As String
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Title = "Select an Excel File"
.Filters.Add "Excel Files", "*.csv?", 1
.AllowMultiSelect = True
Dim sPath As String
If .Show = True Then
chooseFolder = fd.InitialFileName ' Get the folder path.
End If
End With
End Function
CodePudding user response：
Copy CSV Files to a New Workbook
Private Sub CommandButton1_Click()
CopyCsvFilesToNewWorkbook
End Sub
Sub CopyCsvFilesToNewWorkbook()
' Select the source folder path.
Dim sPath As String: sPath = GetSelectedFolderPath
If Len(sPath) = 0 Then Exit Sub ' dialog canceled
Debug.Print "Folder Path: """ & sPath & """"
' Write the CSV file paths to an array.
Dim CsvFilePaths As Variant: CsvFilePaths = FilePathsToArray(sPath, "*.csv")
If IsEmpty(CsvFilePaths) Then Exit Sub ' no files found
Debug.Print "CSV File Paths"
Debug.Print Join(CsvFilePaths, vbLf)
' Copy the CSV files to a new workbook.
Dim dwb As Workbook: Set dwb = CsvFilesToNewWorkbook(CsvFilePaths)
If dwb Is Nothing Then Exit Sub
Debug.Print "The new workbook '" & dwb.Name & "' contains " _
& dwb.Worksheets.Count & " worksheets."
' Continue with saving the workbook... 'dwb.SaveAs...'
End Sub
Function GetSelectedFolderPath( _
Optional ByVal InitialFolderPath As String = "", _
Optional ByVal DialogTitle As String = "Browse", _
Optional ByVal DialogButtonName As String = "OK") _
As String
Dim FolderPath As String
Dim Canceled As Boolean
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = DialogTitle
.ButtonName = DialogButtonName
Dim pSep As String: pSep = Application.PathSeparator
If Len(InitialFolderPath) > 0 Then
FolderPath = InitialFolderPath
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
.InitialFileName = FolderPath
End If
If .Show Then
FolderPath = .SelectedItems(1)
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Else
Canceled = True
End If
End With
If Canceled Then
MsgBox "Dialog canceled.", vbExclamation, "GetSelectedFolderPath"
Exit Function
End If
GetSelectedFolderPath = FolderPath
End Function
Function FilePathsToArray( _
ByVal SourceFolderPath As String, _
Optional ByVal FilePattern As String = "*.*") _
As Variant
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(SourceFolderPath)
Dim LCaseFilePattern As String: LCaseFilePattern = LCase(FilePattern)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim fsoFile As Object
Dim FilePath As String
For Each fsoFile In fsoFolder.Files
FilePath = fsoFile.Path
If LCase(FilePath) Like LCaseFilePattern Then
dict(FilePath) = Empty
End If
Next fsoFile
If dict.Count = 0 Then
MsgBox "No files found.", vbExclamation
Exit Function
End If
FilePathsToArray = dict.Keys
End Function
' This method is written as a function
' to return a reference to the new workbook.
Function CsvFilesToNewWorkbook( _
ByVal CsvFilePaths As Variant) _
As Workbook
' It is assumed that none of the CSV files are open in the current application
' i.e. if a file is open, modified but not saved, this procedure
' will copy the modified file but will also close it without saving the changes.
' If a file is open in another application, it might not get copied.
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim dwb As Workbook
Dim n As Long
Dim FilesCount As Long
Dim FilePath As String
For n = LBound(CsvFilePaths) To UBound(CsvFilePaths)
FilePath = CsvFilePaths(n)
On Error Resume Next
Set swb = Workbooks.Open(FilePath, True, True)
On Error GoTo 0
If Not swb Is Nothing Then ' workbook is open
Set sws = swb.Worksheets(1) ' the one and only
FilesCount = FilesCount 1
If FilesCount = 1 Then ' the first source workbook
' Copy the worksheet to a new workbook.
sws.Copy ' creates a new single-worksheet workbook
' Reference this new workbook, the destination workbook.
Set dwb = Workbooks(Workbooks.Count)
Else ' all source workbooks but the first
' Copy the source worksheet to the destination workbook.
sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
End If
swb.Close SaveChanges:=False
Set swb = Nothing ' reset
'Else ' workbook is not open; do nothing
End If
Next n
If Not dwb Is Nothing Then
'dwb.Saved = True ' to easily close while testing
Set CsvFilesToNewWorkbook = dwb
End If
Application.ScreenUpdating = True
'MsgBox "Copied " & FilesCount & "(" & n & ")" & " CSV file" _
& IIf(FilesCount = 1, "", "s") & " to a new workbook.", _
IIf(FilesCount = 0, vbExclamation, vbInformation), _
"CsvFilesToNewWorkbook"
End Function