VBA to select multiple CSV files, merge to single sheet, add formula then pivot results in XL07

[Andyatwork]

Hello board,

I've been searching the internet for VB code I can hack together to allow a user to;

• select multiple CSV files (found something in the VB help resource for FILEDIALOG)
• automatically merge those files into a single worksheet while retaining a single header row (found this post http://www.mrexcel.com/forum/excel-...e-all-new-csvs-folder-into-one-worksheet.html )
• autofill some basic formula to the merged WS (date checking to determine age of a thing in the file, I think can manage this bit in VB)
• Auto pivot the results into a new WS (was just going to record doing it manually as I think that should be fairly straight forward)
• Finally prompt the user to Save As.. (which I also think I can manage)

I managed to hack together elements of the code I found under FileDialog and the linked post but it is doing weird things and I don't know why.

I tested it on two CSV files, one of @38k rows and one of @180k rows. The macro looped until all million plus rows were full and then fell over.
I'm assuming there is something wrong with the Do...Loop

It also wraps each cell's data from the CSVs in quotes which I think I can fix with some sort of find/replace but if anyone knows a nifty bit of code to stop it from happening in the first place, that would be very helpful. However, that is a secondary concern to the fact it is endlessly pasting the contents of the selected files instead of just merging them all once.

I would very much appreciate someone casting an expert eye over the code and pointing out the obvious schoolboy error(s) I cannot see.

I'm aware that some declared variables don't get called or used, this is a work in progress.

My code:

Sub pick_and_merge()

    Dim strSourcePath As String
    Dim strDestPath As String
    Dim strFile As String
    Dim strData As String
    Dim x As Variant
    Dim Cnt As Long
    Dim r As Long
    Dim c As Long

    'Declare a variable as a FileDialog object.
    Dim fd As FileDialog

    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    'Declare a variable to contain the path of each selected item. Even though the path is aString,
    'the variable must be a Variant because For Each...Next
    'routines only work with Variants and Objects.
    Dim vrtSelectedItem As Variant

    'Use a With...End With block to reference the FileDialog object.
    With fd

        'Use the Show method to display the File Picker dialog box and return the user's action.
        'The user pressed the button.
        If .Show = -1 Then
            'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
            Do While Len(vrtSelectedItem) > 0
            Cnt = Cnt + 1
            If Cnt = 1 Then
                r = 1
            Else
                r = Cells(Rows.Count, "A").End(xlUp).Row + 1
        End If
        Open vrtSelectedItem For Input As #1
            If Cnt > 1 Then
                Line Input #1, strData
            End If
            Do Until EOF(1)
                Line Input #1, strData
                x = Split(strData, ",")
                For c = 0 To UBound(x)
                    Cells(r, c + 1).Value = Trim(x(c))
                Next c
                r = r + 1
            Loop
        Close #1
'        Name strSourcePath & strFile As strDestPath & strFile
'        strFile = Dir
    Loop
            
        
    
    Application.ScreenUpdating = True
    
    If Cnt = 0 Then _
        MsgBox "No CSV files were found...", vbExclamation
            
        Next vrtSelectedItem
    End If
End With
End Sub

 

[Eric Golf]

Hello board,

...

I'm assuming there is something wrong with the Do...Loop

...

My code:

Sub pick_and_merge()

    Dim strSourcePath As String
    Dim strDestPath As String
    Dim strFile As String
    Dim strData As String
    Dim x As Variant
    Dim Cnt As Long
    Dim r As Long
    Dim c As Long

    'Declare a variable as a FileDialog object.
    Dim fd As FileDialog

    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    'Declare a variable to contain the path of each selected item. Even though the path is aString,
    'the variable must be a Variant because For Each...Next
    'routines only work with Variants and Objects.
    Dim vrtSelectedItem As Variant

    'Use a With...End With block to reference the FileDialog object.
    With fd

        'Use the Show method to display the File Picker dialog box and return the user's action.
        'The user pressed the button.
        If .Show = -1 Then
            'Step through each string in the FileDialogSelectedItems collection.
[COLOR="#FF0000"]            For Each vrtSelectedItem In .SelectedItems[/COLOR]
                Do While Len(vrtSelectedItem) > 0
                    Cnt = Cnt + 1
                    If Cnt = 1 Then
                        r = 1
                    Else
                        r = Cells(Rows.Count, "A").End(xlUp).Row + 1
                    End If
                    Open vrtSelectedItem For Input As #1
                    If Cnt > 1 Then
                        Line Input #1, strData
                    End If
                    Do Until EOF(1)
                        Line Input #1, strData
                        x = Split(strData, ",")
                        For c = 0 To UBound(x)
                            Cells(r, c + 1).Value = Trim(x(c))
                        Next c
                        r = r + 1
                    Loop
                    Close #1
'                    Name strSourcePath & strFile As strDestPath & strFile
'                    strFile = Dir
                Loop    
    
                Application.ScreenUpdating = True
    
                If Cnt = 0 Then _
                    MsgBox "No CSV files were found...", vbExclamation
            
[COLOR="#FF0000"]                    Next vrtSelectedItem[/COLOR]
                End If
   
  End With
End Sub

Hi,

As far as I can see you are missing an End If, which probably should go just after the "MsgBox "No CSV files were found...", vbExclamation
". This is putting the lines in Red out of synch with where you expect them to be.

See the re-indented code above, you always want to align start & end loops, Ifs, Withs etc. so you can see they match up.

Hope this helps,

Eric

 

[Andyatwork]

Hi Eric,

Thanks for replying. Yeah, I knew the indents were out of whack and got myself in a mess trying to make sense of them myself.

I tried putting an extra End If where you suggested at got a compile error suggesting it was extraneous; no Block If to go with it.

I've tried lining up the varios With..End With, IF ...End If, Do...Loop but i count 4 Ifs, and only 3 End Ifs.
i'm confused, I didn't think it would compile if they were mismatched. What am i missing?

    With fd
    'Use the Show method to display the File Picker dialog box and return the user's action.
    'The user pressed the button.
        If .Show = -1 Then
        Application.ScreenUpdating = False
    
    'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
                    Do While Len(vrtSelectedItem) > 0
                        Cnt = Cnt + 1
                        If Cnt = 1 Then
                            r = 1
                        Else
                            r = Cells(Rows.Count, "A").End(xlUp).Row + 1
                        End If
                        
                        Open vrtSelectedItem For Input As #1
                            If Cnt > 1 Then
                                Line Input #1, strData
                            End If
                            
                            Do Until EOF(1)
                                Line Input #1, strData
                                    x = Split(strData, ",")
                                For c = 0 To UBound(x)
                                    Cells(r, c + 1).Value = Trim(x(c))
                                Next c
                                    r = r + 1
                            Loop
                        Close #1
                    Loop
                If Cnt = 0 Then _
                MsgBox "No CSV files were found...", vbExclamation
                [COLOR=#ff0000]'tried inserting End If here and get a compile error, "no block if"
[/COLOR]          Next vrtSelectedItem
        End If
        
    End With
    Application.ScreenUpdating = True
End Sub

 

[Eric Golf]

Hi,

More to the point, what did I miss, because I wondered how it could compile with a missing End If. Answer - the line continuation character at the end of " If Cnt = 0 Then _"

An If statement can all be done on one line which means End If is not required. Never use it myself due to difficult to spot, as evidenced here

So, original code good, personally I would take out the underscore & add the End If.

Your problem,

The macro looped until all million plus rows were full and then fell over

?

                 Do While Len(vrtSelectedItem) > 0
                        Cnt = Cnt + 1
                        If Cnt = 1 Then
                            r = 1
                        Else
                            r = Cells(Rows.Count, "A").End(xlUp).Row + 1
                        End If
                        
                        Open vrtSelectedItem For Input As #1
                            If Cnt > 1 Then
                                Line Input #1, strData
                            End If
                            
                            Do Until EOF(1)
                                Line Input #1, strData
                                    x = Split(strData, ",")
                                For c = 0 To UBound(x)
                                    Cells(r, c + 1).Value = Trim(x(c))
                                Next c
                                    r = r + 1
                            Loop
                        Close #1
                    Loop

I don't see anywhere in this Loop that the value of Len(vrtSelectedItem) will change? I am not even sure what this refers to, length of filename, length of the file in bits? Neither of these will change?

Not sure what this loop is intended for, as you are already looping through each file looping until EOF? Though I don't tend to read files line by line so may be wrong.

Again, hope this helps,

Eric.

 

[Andyatwork]

TIL: Ifs can be single line and blocks, cool.

My understanding of the vrtSelectedItems and .SelectedItems is very limited, but when testing the basic code in the VBA resource under FileDialog it allows the user to select multiple files, the path to those files gets written to a virtual table as a text string and

            'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
                'vrtSelectedItem is aString that contains the path of each selected item.
                'You can use any file I/O functions that you want to work with this path.
                'This example displays the path in a message box.
                MsgBox "The path is: " & vrtSelectedItem
            Next vrtSelectedItem

allows an operation to be carried out on each path string.

I was hoping that hacking it into Domenic's original code from http://www.mrexcel.com/forum/excel-q...worksheet.html would allow each selected file to be called in a For each...Next loop.

The Do While Len(vrtSelectedItem) > 0 bit is my hamfisted attempt to bodge the above into the below. It doesn't seem to fit so I am obviously lacking in understanding.

Sub ImportCSV()
    Dim strSourcePath As String
    Dim strDestPath As String
    Dim strFile As String
    Dim strData As String
    Dim x As Variant
    Dim Cnt As Long
    Dim r As Long
    Dim c As Long
    
    Application.ScreenUpdating = False
    
    'Change the path to the source folder accordingly
    strSourcePath = "C:\Path\"
    
    If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
    
    'Change the path to the destination folder accordingly
    strDestPath = "C:\Path\"
    
    If Right(strDestPath, 1) <> "\" Then strDestPath = strDestPath & "\"
    
    strFile = Dir(strSourcePath & "*.csv")
    
[COLOR=#ff0000]' I tried to crowbar the vrtselecteditems code in here[/COLOR]
    Do While Len(strFile) > 0
        Cnt = Cnt + 1
        If Cnt = 1 Then
            r = 1
        Else
            r = Cells(Rows.Count, "A").End(xlUp).Row + 1
        End If
        Open strSourcePath & strFile For Input As #1
            If Cnt > 1 Then
                Line Input #1, strData
            End If
            Do Until EOF(1)
                Line Input #1, strData
                x = Split(strData, ",")
                For c = 0 To UBound(x)
                    Cells(r, c + 1).Value = Trim(x(c))
                Next c
                r = r + 1
            Loop
        Close #1
        Name strSourcePath & strFile As strDestPath & strFile
        strFile = Dir
    Loop
    
    Application.ScreenUpdating = True
    
    If Cnt = 0 Then _
        MsgBox "No CSV files were found...", vbExclamation
    
End Sub

I don't understand the logic of Domenic's code though and was just trying to find something that would let me select multiple CSV files (potentially from a folder containing multiple other files) and have them magically imported and merged into a single worksheet. When stepping through the code I did see that it appeared to be reading data line by line and adding information cell by cell, and a subsequent test showed that it was in fact just pasting the 2nd of two selected files infinitely until Excel was full and the macro fell over.

If there is a more elegant (and faster) way fo doing that I would love to know.

 

[Eric Golf]

Hi,

In Dominics code the loop below is iterating through all files in a folder until there are no more files. From VBA Help - "Dir returns the first file name that matches pathname. To get any additional file names that match pathname, call Dir again with no arguments. When no more file names match, Dir returns a zero-length string ("")"

Do While Len(strFile) > 0
    
       ...

        strFile = Dir
  Loop

Your code below performs this function instead, so no need for both

      'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
                 ...
            Next vrtSelectedItem

suggest you try this

Sub pick_and_merge()

    Dim strSourcePath As String
    Dim strDestPath As String
    Dim strFile As String
    Dim strData As String
    Dim x As Variant
    Dim Cnt As Long
    Dim r As Long
    Dim c As Long

    'Declare a variable as a FileDialog object.
    Dim fd As FileDialog

    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    'Declare a variable to contain the path of each selected item. Even though the path is aString,
    'the variable must be a Variant because For Each...Next
    'routines only work with Variants and Objects.
    Dim vrtSelectedItem As Variant

    'Use a With...End With block to reference the FileDialog object.
    With fd

        'Use the Show method to display the File Picker dialog box and return the user's action.
        'The user pressed the button.
        If .Show = -1 Then
            'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
                    Cnt = Cnt + 1
                    If Cnt = 1 Then
                        r = 1
                    Else
                        r = Cells(Rows.Count, "A").End(xlUp).Row + 1
                    End If
                    Open vrtSelectedItem For Input As #1
                    If Cnt > 1 Then
                        Line Input #1, strData
                    End If
                    Do Until EOF(1)
                        Line Input #1, strData
                        x = Split(strData, ",")
                        For c = 0 To UBound(x)
                            Cells(r, c + 1).Value = Trim(x(c))
                        Next c
                        r = r + 1
                    Loop
                    Close #1
                Loop    
    
                Application.ScreenUpdating = True
    
                If Cnt = 0 Then 
                    MsgBox "No CSV files were found...", vbExclamation
                End If
            Next vrtSelectedItem
        End If
  End With
End Sub

Good luck,

Eric

 

[Andyatwork]

That did it! I had to take out the second Loop after Close #1 but it works.

Sub pick_and_merge()
    Dim strSourcePath As String
    Dim strDestPath As String
    Dim strFile As String
    Dim strData As String
    Dim x As Variant
    Dim Cnt As Long
    Dim r As Long
    Dim c As Long
    
    Application.ScreenUpdating = False
    
    'Declare a variable as a FileDialog object.
    Dim fd As FileDialog
    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    'Declare a variable to contain the path
    'of each selected item. Even though the path is aString,
    'the variable must be a Variant because For Each...Next
    'routines only work with Variants and Objects.
    Dim vrtSelectedItem As Variant
    'Use a With...End With block to reference the FileDialog object.
    With fd
    'Use the Show method to display the File Picker dialog box and return the user's action.
    'The user pressed the button.
        If .Show = -1 Then
    
    'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
                        Cnt = Cnt + 1
                        If Cnt = 1 Then
                            r = 1
                        Else
                            r = Cells(Rows.Count, "A").End(xlUp).Row + 1
                        End If
                        
                        Open vrtSelectedItem For Input As #1
                            If Cnt > 1 Then
                                Line Input #1, strData
                            End If
                            
                            Do Until EOF(1)
                                Line Input #1, strData
                                    x = Split(strData, ",")
                                For c = 0 To UBound(x)
                                    Cells(r, c + 1).Value = Trim(x(c))
                                Next c
                                    r = r + 1
                            Loop
                        Close #1
                                   If Cnt = 0 Then _
                MsgBox "No CSV files were found...", vbExclamation
                'tried inserting End If here and get a compile error, "no block if"
            Next vrtSelectedItem
        End If
        
    End With
    'Set the object variable to Nothing.
    Set fd = Nothing
    Application.ScreenUpdating = True
End Sub

Many thanks for your advice Eric.


Now, while this eventually does what I wanted, it takes a ludicrous amount of time as I understand it is chopping and pasting individual cells iteratively. My quest is now to make this faster....

 

[Andyatwork]

After some more stumbling around the internet I cobbled together the below, which seems to do what I want quite happily.

I'm feeling quite pleased with myself.

Option Explicit
Sub pick_and_merge()
    Dim Cnt As Long
    Dim destCell As Range
    Dim fd As FileDialog
    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    'Declare a variable to contain the path of each selected item.
    Dim vrtSelectedItem As Variant
    Application.ScreenUpdating = False
    'Use a With...End With block to reference the FileDialog object.
    With fd
    'Use the Show method to display the File Picker dialog box and return the user's action.
    'The user pressed the button.
        If .Show = -1 Then
    
    'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
    
    'counter used to determine where to paste the data, if counter =1 start in A1, if counter
    'if counter is greater than 1 then find first blank cell in col A and paste from there.
                Cnt = Cnt + 1
                
                If Cnt = 1 Then
                    Set destCell = Worksheets("Extracts").Range("A1")
                Else
                    Set destCell = Worksheets("Extracts").Cells _
                    (Rows.Count, "A").End(xlUp).Offset(1)
                End If
                
                If Cnt = 1 Then
                    With destCell.Parent.QueryTables.Add(Connection:="TEXT;" & _
                    vrtSelectedItem, Destination:=destCell)
                        .TextFileStartRow = 1
                        .TextFileParseType = xlDelimited
                        .TextFileCommaDelimiter = True
                        .Refresh BackgroundQuery:=False
                    End With
                Else
                    With destCell.Parent.QueryTables.Add(Connection:="TEXT;" & _
                    vrtSelectedItem, Destination:=destCell)
                        .TextFileStartRow = 2
                        .TextFileParseType = xlDelimited
                        .TextFileCommaDelimiter = True
                        .Refresh BackgroundQuery:=False
                    End With
                End If
            Next vrtSelectedItem
            If Cnt = 0 Then _
                MsgBox "No CSV files were found...", vbExclamation
        End If
    End With
    Set fd = Nothing
    Application.ScreenUpdating = True
End Sub

 

[Eric Golf]

... and so the eternal journey for excellence begins

Glad you're sorted

Eric.