Excel macro - open files - copy data - rename worksheet close files

[swilson2006]

Hi there

I hope someone can help with a small macro.

The macro is to:

1. Look inside a specified folder at all csv files
2. Look at column G of the csv file which contains a date and time in this format 28/02/2018 08:31:10 and take the date from this the second row and then create a worksheet in a pre-set XLSX file with the data as the worksheet name. Copy all the CSV data to the XLSX file and then close all files and move on to the next file.
3. If the worksheet already exists then move on to the next file until all files have been processed.
4. Insert a column before column C called "PYMT TYPE".
5. Close the XLSX file and CSV files.

I would like it so that it does not duplicate a worksheet and just skips it.

Basically I am creating an XLSX file from daily worksheet so I can combine all the data in the CSVs into one file.

I appreciate your help.

 

[ranman256]

not sure exactly what you want but here's a start....


usage:
getCsvFilesInDir "c:\temp"

Private Sub getCsvFilesInDir(ByVal pvSrcDir)
Dim FSO, oFolder, oFile, oRX
Dim sCriteria As String, sFile As String
Dim iCnt As Integer
Dim vXFmt, vDate


On Error GoTo errGetFiles


If Right(pvSrcDir, 1) <> "\" Then pvSrcDir = pvSrcDir & "\"


Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(pvSrcDir)


For Each oFile In oFolder.Files
  If InStr(oFile.Name, ".csv") > 0 Then            'open CSV file here
     sFile = pvSrcDir & oFile.Name
     
     Workbooks.Add
     ImportCsv sFile
     vDate = Range("G2").Value
     
       'do stuff here?
       
         'save as new name
     vNewFile = "C:\temp\" & Format(vDate, "yyyymmdd-hhnnss") & ".xls"
    
     ActiveWorkbook.SaveAs Filename:=vNewFile, FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
         
     ActiveWorkbook.Close
  End If
Next
MsgBox "Done"


endit:
Set oFile = Nothing
Set oFolder = Nothing
Set FSO = Nothing
Exit Sub


errGetFiles:
  MsgBox Err.Description, , Err
End Sub




Private Sub ImportCsv(ByVal pvFile)
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & pvFile, Destination:=Range("$A$1"))
        .CommandType = 0
        .Name = "names_1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C1").Value = "PYMT TYPE"
End Sub