Option Explicit
Public Enum FilterType
CSV = 0
XL = 1
End Enum
Private Const FilterCSV As String = "CSV Files (*.csv), *.csv"
Private Const FilterXL As String = "Excel Files (*.xl*), *.xl*"
Dim TargetCount As Long
Dim TargetCountA As Long
Sub CorrectColumnInCSV_Folder()
Dim SelectFolder As FileDialog
Dim FSO As Object
Dim TargetFolder As Object
Dim TargetFile As Object
Set SelectFolder = Application.FileDialog(msoFileDialogFolderPicker)
TargetCount = 0
TargetCountA = 0
SelectFolder.AllowMultiSelect = False
If SelectFolder.Show Then
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TargetFolder = FSO.GetFolder(SelectFolder.SelectedItems.Item(1))
For Each TargetFile In TargetFolder.Files
If UCase(Right(TargetFile.Name, 4)) = ".CSV" Then
TargetCountA = TargetCountA + 1
If ISFILEOPEN(TargetFile.Name) = False Then
TargetCount = CorrectAdditionalColumnInCSV(Target:=TargetFile.Path, _
ColumnCount:=18, _
MergeColStart:=15 _
) + TargetCount
End If
End If
Next TargetFile
End If
MsgBox TargetCount & " of " & TargetCountA & " files have been processed.", vbInformation, "Complete!"
End Sub
Sub CorrectColumnInCSV_File()
Dim TargetFile As Variant
Dim TargetName As String
Dim LoopStep As Long
TargetFile = Application.GetOpenFilename(FilterReturn(CSV), MultiSelect:=True)
If Not IsArray(TargetFile) Then
Exit Sub
End If
TargetCount = 0
TargetCountA = UBound(TargetFile) - LBound(TargetFile) + 1
For LoopStep = LBound(TargetFile) To UBound(TargetFile)
TargetName = Right(TargetFile(LoopStep), Len(TargetFile(LoopStep)) - InStrRev(TargetFile(LoopStep), "\"))
If ISFILEOPEN(TargetName) = False Then
TargetCount = CorrectAdditionalColumnInCSV(Target:=TargetFile(LoopStep), _
ColumnCount:=18, _
MergeColStart:=15 _
) + TargetCount
End If
Next LoopStep
MsgBox TargetCount & " of " & TargetCountA & " files have been processed.", vbInformation, "Complete!"
End Sub
Private Function CorrectAdditionalColumnInCSV( _
ByVal Target As Variant, _
ByVal ColumnCount As Long, _
ByVal MergeColStart As Long, _
Optional ByVal Delimiter As String = ",", _
Optional ByVal ReplaceDelimiter As String = " ") As Long
Dim TempFile As String
Dim TempName As String
Dim TempPath As String
Dim TempExt As String
Dim FileNum1 As Long
Dim FileNum2 As Long
Dim LineText As String
Dim LineOutput As String
Dim LineItems() As String
Dim NDX As Long
Dim i As Long
TempPath = Left(Target, InStrRev(Target, "\"))
TempName = Right(Target, Len(Target) - Len(TempPath))
TempExt = Right(TempName, Len(TempName) - InStrRev(TempName, "."))
TempName = Left(TempName, Len(TempName) - Len(TempExt) - 1) & "(temp write)." & TempExt
TempFile = TempPath & TempName
FileNum1 = FreeFile()
Open Target For Input Access Read As #FileNum1
FileNum2 = FreeFile()
Open TempFile For Output Access Write As #FileNum2
Do While Not EOF(FileNum1)
LineText = ""
LineOutput = ""
Line Input #FileNum1, LineText
If Right(LineText, 1) = Delimiter Then LineText = Left(LineText, Len(LineText) - 1)
LineItems = Split(LineText, Delimiter)
If UBound(LineItems) - LBound(LineItems) + 1 > ColumnCount Then
LineOutput = WorksheetFunction.Substitute(LineText, Delimiter, ReplaceDelimiter, MergeColStart)
If InStr(1, LineOutput, Chr(34), vbTextCompare) > 0 Then
LineOutput = Replace(LineOutput, Chr(34), vbNullString)
End If
Else
LineOutput = LineText
End If
Print #FileNum2, LineOutput
Loop
CorrectAdditionalColumnInCSV = 1
ExitWithoutError:
Close #FileNum1
Close #FileNum2
If Dir(TempFile, vbNormal) <> "" Then
If Dir(Target, vbNormal) <> "" Then FileCopy TempFile, Target
Kill TempFile
End If
Exit Function
ExitWithError:
CorrectAdditionalColumnInCSV = 0
Resume ExitWithoutError
End Function
Function ISFILEOPEN(FileName As String) As Boolean
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
Select Case iErr
Case 0: ISFILEOPEN = False
Case 70: ISFILEOPEN = True
Case Else: Error iErr
End Select
On Error GoTo 0
End Function
Private Function FilterReturn(ByVal Value As FilterType) As String
Select Case Value
Case FilterType.CSV: FilterReturn = FilterCSV
Case FilterType.XL: FilterReturn = FilterXL
End Select
End Function
Edit: This should run fairly fast on a large set of files, since we're basically editing everything in memory as a text stream. I can run a test batch of 100 files (copies of your sample file with row 1 removed) and it runs almost instantaneously. You shouldn't have any problems running this on all of your files, assuming the structure is similar (as previously described).
Reply With Quote
