Look @ My Code - Aggregates CSV Files Into Single Spreadsheet - 2 Issues

[mikeoly]

First off, I always appreciate the time all you folks put into reviewing all the posts VBA users have...and your patience for all the reposts!

My two issues:

1. Runtime Error '7' - Out of Memory

-This occurred for the first time today. We're running a virtual network system, not sure if that has anything to do with it.

2. Will only run once.

- The macro will only run once. If I'd like to copy the spreadsheet containing the macro into another folder, it won't run again. Essentially, I need to copy the macro into a new spreadsheet every time I'd like to run the macro. Does anyone have an idea of how I can make this more dynamic? I'm thinking that I'd like to incorporate an 'Application.FileDialog(msoFileDialogFolderPicker)' and simply choose the folder I want to run the macro in.

Sub ImportAllCSV()
  Dim FName As Variant, R As Long
  R = 1
  FName = Dir("*.csv")
  Do While FName <> ""
    ImportCsvFile FName, ActiveSheet.Cells(R, 1)
    R = ActiveSheet.UsedRange.Rows.Count + 1
    FName = Dir
  Loop
End Sub
Sub ImportCsvFile(FileName As Variant, Position As Range)
  With ActiveSheet.QueryTables.Add(Connection:= _
      "TEXT;" & FileName _
      , Destination:=Position)
      .Name = Replace(FileName, ".csv", "")
      .FieldNames = True
      .RowNumbers = False
      .FillAdjacentFormulas = False
      .RefreshOnFileOpen = False
      .BackgroundQuery = True
      .RefreshStyle = xlInsertDeleteCells
      .SavePassword = False
      .SaveData = True
      .AdjustColumnWidth = True
      .TextFilePromptOnRefresh = False
      .TextFilePlatform = xlMacintosh
      .TextFileStartRow = 1
      .TextFileParseType = xlDelimited
      .TextFileTextQualifier = xlTextQualifierDoubleQuote
      .TextFileConsecutiveDelimiter = False
      .TextFileTabDelimiter = True
      .TextFileSemicolonDelimiter = False
      .TextFileCommaDelimiter = False
      .TextFileSpaceDelimiter = False
      .TextFileOtherDelimiter = ","
      .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
      .Refresh BackgroundQuery:=False
  End With
End Sub

Any other suggestions are welcome! Thanks!

[Kenneth Hobs]

I don't understand the need to copy the macro into a spreadsheet. Maybe you mean workbook? That should work fine. Just copy your code in a Module(s).

I could solve this for you fully but maybe you can get it from the code examples.

For the folder picking option:

Sub test_GetFolder()  
  MsgBox Get_Folder(ThisWorkbook.path, "Folder Picker")
End Sub
 
Function Get_Folder(Optional FolderPath As String, _
  Optional HeaderMsg As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If FolderPath = "" Then
          .initialFilename = Application.DefaultFilePath
          Else
          .initialFilename = FolderPath
        End If
        .Title = HeaderMsg
        If .show = -1 Then
            Get_Folder = .SelectedItems(1)
        Else
            Get_Folder = ""
        End If
    End With
End Function

For finding CSV files, Dir() can have several issues. Since batch routines are fairly common, I made an example to show you how to replace your Dir() method and how to call a routine and pass the filename as the first and only input parameter. Obviously, you would replace the perco routine with yours. In your routine, remove the 2nd input parameter and add the code from your Dir() routine to set your range for the import.

'http://www.mrexel.com/forum/excel-questions/869792-run-same-macro-multiples-files-same-folder.html

Sub Test_kBatch()
  kBatch "X:\FileFolder\csv\*.csv", "Module1.perco"
End Sub


Sub kBatch(myDir As String, myMacro As String, _
  Optional tfSubFolders As Boolean = False)
  
  Dim s As String, a() As String, v As Variant
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s").StdOut.ReadAll
    Else
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b").StdOut.ReadAll
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    MsgBox myDir & " files not found.", vbCritical, "Macro Ending"
    Exit Sub
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For Each v In a()
    If tfSubFolders Then
      'Debug.Print v
      Application.Run myMacro, v
      Else
      s = Left$(myDir, InStrRev(myDir, "\"))
      Application.Run myMacro, s & v
    End If
  Next v
End Sub


Sub perco(aFile As String)
  Dim MyString As String, MyVals As Variant, c As Range, lr As Long
  Dim wb As Workbook
  
  If Len(Dir(aFile)) = 0 Then
    MsgBox aFile & " does not exist.", vbCritical, "Macro Ending"
    Exit Sub
  End If
  
  Set wb = Workbooks.Open(aFile)
  
  lr = Cells(Rows.Count, "A").End(xlUp).Row
  For Each c In Range("A1:A" & lr)
    MyString = c.Value
    MyVals = Split(MyString, ",")
    MyVals(5) = "^^"
    c.Value = Replace(Join(MyVals, ","), ",^^,", ",")
  Next c
  
  wb.Close True
End Sub

[mikeoly]

Thanks! This should be very helpful. I'll report back.

Happy Holidays!