Option Explicit
Public Sub Reform_CSV()
Const cMyFolder As String = "E:\MyExtraDrive\User\Folder\SubFolder" ' <<<< change as desired where your files are located
Dim oWb As Workbook
Dim vDlgResult As Variant
Dim bCSVResult As Boolean
Dim lLastRow As Long
Dim i As Long
vDlgResult = FilePicker_CSV(cMyFolder)
If Not vDlgResult(0) = vbCancel Then
For i = LBound(vDlgResult) To UBound(vDlgResult)
Set oWb = Workbooks.Add
ActiveSheet.Range("A2").Select
ActiveWindow.FreezePanes = True
bCSVResult = ImportCSV(oWb.Sheets(1), CStr(vDlgResult(i)))
If bCSVResult Then
With oWb.Sheets(1)
lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Columns("A:F").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Columns("H:H").Copy Destination:=.Columns("C:C")
.Columns("I:I").Copy Destination:=.Columns("D:D")
.Columns("J:J").Copy Destination:=.Columns("E:E")
.Columns("L:L").Copy Destination:=.Columns("F:F")
.Columns("H:W").Delete Shift:=xlToLeft
.Range("A1").Value = "ID"
.Range("B1").Value = "trksegID"
.Range("C1").Value = "lat"
.Range("D1").Value = "lon"
.Range("E1").Value = "ele"
.Range("G1").Value = "time"
.Range("H1").Value = "time_N"
.Range("A2").Value = "1"
.Range("B2").Value = "1"
.Range("H2").Formula = "= G2 + TIME(7,0,0)"
.Range("A2").AutoFill Destination:=.Range("A2:A" & lLastRow), Type:=xlFillSeries
.Range("B2").AutoFill Destination:=.Range("B2:B" & lLastRow), Type:=xlFillDefault
.Range("H2").AutoFill Destination:=.Range("H2:H" & lLastRow), Type:=xlFillDefault
.Columns("C:D").NumberFormat = "0.0000000"
.Columns("E:E").NumberFormat = "0.0"
.Columns("E:E").ColumnWidth = 7
.Columns("G:H").NumberFormat = "yyyy/mm/dd hh:mm:ss"
End With
Else
MsgBox "Something unexpected went wrong", vbExclamation, "Reform_CSV"
End If
Next i
Set oWb = Nothing
Else
MsgBox "User has canceled", vbExclamation, "Reform_CSV"
End If
End Sub
Public Function FilePicker_CSV(ByRef argFolderPath As String) As Variant()
Dim vFiles() As Variant
Dim oFSO As Object
Dim sPath As String
Dim fd As FileDialog
Dim i As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
If Not oFSO.FolderExists(argFolderPath) Then
sPath = Environ("USERPROFILE")
End If
Set oFSO = Nothing
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = IIf(Right(argFolderPath, 1) = "\", argFolderPath, argFolderPath & "\")
.AllowMultiSelect = True
.Title = "Import CSV file"
.ButtonName = "Import File(s)"
.InitialView = msoFileDialogViewDetails
.Filters.Clear
.Filters.Add Description:="CSV (Comma-Separated Values)", Extensions:="*.csv", Position:=1
.Filters.Add Description:="All Files", Extensions:="*.*", Position:=2
.FilterIndex = 1
If .Show = True Then
ReDim vFiles(.SelectedItems.Count - 1)
For i = 0 To .SelectedItems.Count - 1
vFiles(i) = .SelectedItems.Item(i + 1)
Next i
Else
ReDim vFiles(0)
vFiles(0) = vbCancel
End If
End With
Set fd = Nothing
FilePicker_CSV = vFiles
End Function
Public Function FileStripExt(ByRef argFileName As String) As String
Dim tLen As Long
FileStripExt = argFileName
tLen = InStrRev(argFileName, ".", -1, vbTextCompare)
If tLen <> 0 Then
tLen = 1 + Len(argFileName) - tLen
FileStripExt = Left(argFileName, Len(argFileName) - tLen)
End If
End Function
Public Function ImportCSV(ByVal argSht As Worksheet, ByRef argCSV_FullName As String) As Boolean
Dim oFSO As Object
Dim sIDName As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FileExists(argCSV_FullName) Then
sIDName = FileStripExt(oFSO.GetFileName(argCSV_FullName))
On Error GoTo SUB_ERROR
With argSht.QueryTables.Add(Connection:="TEXT;" & argCSV_FullName, Destination:=Range("$A$1"))
.Name = sIDName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.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, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = ","
.Refresh BackgroundQuery:=False
End With
ImportCSV = True
Else
ImportCSV = False
End If
GoTo SUB_QUIT
SUB_ERROR:
ImportCSV = False
MsgBox "An error occured." & vbCrLf & _
"Number: " & Err.Number & vbCrLf & _
"Description: " & Err.Description & vbCrLf & _
"Source: " & Err.Source & " (procedure ImportCSV)", vbCritical, "ImportCSV"
Err.Clear
SUB_QUIT:
Set oFSO = Nothing
End Function
drive.google.com
example: test.csv->test_N.csv
