Reputation: 35
I have made the following code where the aim is to save two ranges into a CSV file:
Sub Export_range_to_CSV()
Dim myCSVFileName As String
Dim myWB As Workbook
Dim tempWB As Workbook
Dim range1 As Range
Dim range2 As Range
Set range1 = Sheets("sheet1").Range("G2:G4")
Set range2 = Sheets("sheet1").Range("G5:H53")
Application.DisplayAlerts = False
On Error GoTo err
Set myWB = ThisWorkbook
myCSVFileName = "filepath" & "\" & "name" & VBA.Format(VBA.Now, "yyyymmdd_hhmm") & ".csv"
range1.Copy
Set tempWB = Application.Workbooks.Add(1)
With tempWB
.Sheets(1).Range("A1").PasteSpecial xlPasteValues
range2.Copy
.Sheets(1).Range("A4").PasteSpecial xlPasteValues
.SaveAs Filename:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
err:
Application.DisplayAlerts = True
End Sub
The code above does the job, but for range1
it has commas at the end of the string when saved as CSV. I need to remove these in order for a job downstream to work. How do I get rid of the commas at the end of range1
?
This is how it looks once saved as the CSV file:
range1
- # X=Y, <- need to remove these commas
- # Z=U,
- # M=Q,
range2
- datetime,quantity
- 2021-03-05 23:00:00+00:00,17
- 2021-03-05 23:30:00+00:00,17
- 2021-03-06 00:00:00+00:00,17
- 2021-03-06 00:30:00+00:00,17
I think the problem comes from range1
only having a single column and as soon as range2
comes into play it assumes range1
should be two columns as well.
Upvotes: 3
Views: 2068
Reputation: 55073
exportRangesToCSV
, while removeTrailingCommaInTextFile
is being called near the end, and removeTrailingComma
is being called by removeTrailingCommaInTextFile
.Resume
part). You could easily apply it to the 1st procedure.The Code
Option Explicit
Sub exportRangesToCSV()
Const sName As String = "Sheet1"
Const sAddr As String = "G2:G4,G5:H53"
Const dFolderPath As String = "C:\Test"
Const dLeftBaseName As String = "Name"
Const dTimeFormat As String = "yyyymmdd_hhmm"
Const dFileExtension As String = ".csv"
Const dAddr As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim rg As Range: Set rg = wb.Worksheets(sName).Range(sAddr)
Dim dFilePath As String
dFilePath = dFolderPath & "\" & dLeftBaseName _
& VBA.Format(VBA.Now, dTimeFormat) & dFileExtension
Application.ScreenUpdating = False
With Workbooks.Add()
Dim dCell As Range: Set dCell = .Worksheets(1).Range(dAddr)
Dim srg As Range
For Each srg In rg.Areas
dCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
Set dCell = dCell.Offset(srg.Rows.Count)
Next srg
Application.DisplayAlerts = False
.SaveAs dFilePath, xlCSV
Application.DisplayAlerts = True
.Close False
End With
Application.ScreenUpdating = True
removeTrailingCommaInTextFile dFilePath, True
'wb.FollowHyperlink dFolderPath
End Sub
Sub removeTrailingCommaInTextFile( _
ByVal FilePath As String, _
Optional ByVal removeAllOccurrences As Boolean = False)
Const ProcName As String = "removeTrailingCommaInTextFile"
On Error GoTo clearError
Dim TextFile As Long: TextFile = FreeFile
Dim TempString As String
Open FilePath For Input As TextFile
TempString = Input(LOF(TextFile), TextFile)
Close TextFile
Open FilePath For Output As TextFile
Print #TextFile, removeTrailingComma(TempString, removeAllOccurrences)
Close TextFile
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & err.Number & "':" & vbLf _
& " " & err.Description
Resume ProcExit
End Sub
Function removeTrailingComma( _
ByVal SearchString As String, _
Optional ByVal removeAllOccurrences As Boolean = False) _
As String
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
If removeAllOccurrences Then
.Pattern = ",+$"
Else
.Pattern = ",$"
End If
removeTrailingComma = .Replace(SearchString, "")
End With
End Function
Edit
Arrays
Sub exportRangesToCSVArrays()
Const sName As String = "Sheet1"
Const sAddr As String = "G2:G4,G5:H53"
Const dFolderPath As String = "C:\Test"
Const dLeftBaseName As String = "Name"
Const dTimeFormat As String = "yyyymmdd_hhmm"
Const dFileExtension As String = ".csv"
Const dAddr As String = "A1"
Const Delimiter As String = ","
Dim wb As Workbook: Set wb = ThisWorkbook
Dim rg As Range: Set rg = wb.Worksheets(sName).Range(sAddr)
Dim aCount As Long: aCount = rg.Areas.Count
Dim Data As Variant: ReDim Data(1 To aCount)
Dim rData() As Long: ReDim rData(1 To aCount)
Dim cData() As Long: ReDim cData(1 To aCount)
Dim OneCell As Variant: ReDim OneCell(1 To 1, 1 To 1)
Dim srg As Range
Dim srCount As Long, scCount As Long
Dim drCount As Long, dcCount As Long
Dim n As Long
For Each srg In rg.Areas
n = n + 1
srCount = srg.Rows.Count: scCount = srg.Columns.Count
rData(n) = srCount: cData(n) = scCount
If srCount > 1 Or scCount > 1 Then
Data(n) = srg.Value
Else
Data(n) = OneCell: Data(1, 1) = srg.Value
End If
drCount = drCount + srCount
If scCount > dcCount Then
dcCount = scCount
End If
Next srg
Dim Result() As String: ReDim Result(1 To drCount)
Dim r As Long, i As Long, j As Long
For n = 1 To aCount
For i = 1 To rData(n)
r = r + 1
For j = 1 To cData(n)
Result(r) = Result(r) & CStr(Data(n)(i, j)) & Delimiter
Next j
Result(r) = removeTrailingComma(Result(r), True)
Next i
Next n
Dim dFilePath As String
dFilePath = dFolderPath & "\" & dLeftBaseName _
& VBA.Format(VBA.Now, dTimeFormat) & dFileExtension
Dim TextFile As Long: TextFile = FreeFile
Dim TempString As String
Open dFilePath For Output As TextFile
Print #TextFile, Join(Result, vbLf)
Close TextFile
'wb.FollowHyperlink dFolderPath
End Sub
Upvotes: 1
Reputation: 149335
The last column is calculated by checking the last column of both the ranges. Whichever is higher will be taken. Let me explain it.
Let's say the data is till column J
Set range1 = Sheets("sheet1").Range("G2:G4")
Set range2 = Sheets("sheet1").Range("G5:J53")
Then in this scenario, there will be 3 commas added. Similarly if the last column is K in range2
and last column is H
in range1
then there will be 3 commas added to the 1st range.
The same holds true when you reverse the range
Set range1 = Sheets("sheet1").Range("G5:J53")
Set range2 = Sheets("sheet1").Range("G2:G4")
Now the 2nd range will have extra commas
Solution
Read the data in an array and then remove the last comma. So once your Csv file is written, pass the file to this procedure and it will take care of the rest
The below code reads the csv in an array in one go and then checks every line if it has a ,
on the right. And if it has then it removes it. Finally it deletes the old csv and writes the new file by putting the array in the text file in one go. I have commented the code so you should not have a problem understanding it. But if you do then simply ask.
'~~> Example usage
Sub Sample()
CleanCsv "C:\Users\Siddharth Rout\Desktop\aaa.txt"
End Sub
'~~> Cleans csv
Sub CleanCsv(fl As String)
Dim MyData As String, strData() As String
Dim i As Long
'~~> Read the file in one go into an array
Open fl For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'~~> Check for "," and remove
For i = LBound(strData) To UBound(strData)
If Right(strData(i), 1) = "," Then
Do While Right(strData(i), 1) = ","
strData(i) = Left(strData(i), Len(strData(i)) - 1)
Loop
End If
Next i
'~~> Kill old file
Kill fl
'~~> Output the array in one go into a text file
Dim ff As Long
ff = FreeFile
Open fl For Binary As #ff
Put #ff, , Join(strData, vbCrLf)
Close #ff
End Sub
Upvotes: 1