PDA

View Full Version : Look @ My Code - Aggregates CSV Files Into Single Spreadsheet - 2 Issues



mikeoly
12-21-2015, 09:26 AM
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
12-23-2015, 08:45 AM
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
12-23-2015, 10:15 AM
Thanks! This should be very helpful. I'll report back.

Happy Holidays!