I am trying to export multiple worksheets as an specific csv file with very specific formatting to feed into third party software (PJe Calc Cidadão).
PJe accepts files written in the following format:
"MES_ANO";"VALOR";"FGTS";"FGTS_REC.";"CONTRIBUICAO_SOCIAL";"CONTRIBUICAO_SOCIAL_REC."
"10/2012";"500,00";"S";"S";"S";"S"
"01/2013";"500,00";"S";"N";"S";"N"
I can achieve this formatting by concatenating formatted values in a single column of a worksheet and saving it as a CSV, but once I open the CSV outside excel it is formated as:
"""MES_ANO"";""VALOR"";""FGTS"";""FGTS_REC."";""CONTRIBUICAO_SOCIAL"";""CONTRIBUICAO_SOCIAL_REC."""
"""12/2015"";""1000,00"";""N"";""N"";""N"";""N"""
"""01/2016"";""1000,00"";""N"";""N"";""N"";""N"""
If I simply copy and paste the column in a txt file I can get the format that I want, but since I need to do that multiple times it's a bit tiring
Any advice?
Assuming you want to export Columns A to F on all the sheets in the workbook to separate csv files with unicode encoding then try this ;
Option Explicit
Sub exportcsv()
Const LAST_COL = 6
Const DELIM = ";"
Const QUOTE = """"
Dim wb As Workbook, ws As Worksheet
Dim iRow As Long, iLastRow As Long, s As String, c As Integer, count As Integer
Dim oFSO As Object, oFS As Object
Dim sPath As String, sCSVfile As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
sPath = wb.path & "\"
For Each ws In wb.Sheets
count = 0
sCSVfile = "Sheet_" & ws.Index & ".csv"
Set oFS = oFSO.CreateTextFile(sPath & sCSVfile, True, True) 'overwrite, Unicode
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
For iRow = 1 To iLastRow
s = ""
For c = 1 To LAST_COL
If c > 1 Then s = s & DELIM
s = s & QUOTE & ws.Cells(iRow, c) & QUOTE
Next
oFS.writeline s
count = count + 1
Next
oFS.Close
Debug.Print sCSVfile, count
Next
MsgBox "CSV files exported to " & sPath, vbInformation, "Finished"
End Sub
Related
This is the first week I learn vba so bear with me if I have a lot of questions;-)
So I have two folders, one folder contains the templates I need to update, the other contains the reports that the updates will be copied from. Cell A1 in each template contains the code that is specific to that BU. I need vba to find the code in the file names in the report folder and open that report. The problem is that the report names have different lengths, eg. it's named as XXX region_code_XXXXXXXXXXX, there can be any number of "X" before and after the code.
Sub Macro1()
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder("C:\Users\35264\summary\test")
For Each file In ff.Files
Workbooks.Openfile
Set wbk2 = ActiveWorkbook
Sheets("Summary").Select
Range("A1").Select
rngX = Range("A1").Value
Now I need to find rngX in the file names in the report folder... I can't figure out how. Let me know if anyone can help! Thank you!
I am learning how to use dir function. I think it will be helpful to get the names of the reports first.
Combine the FileSystemObject Object With the Dir Function
Dir cannot be used in nested Do...Loops.
Using the FileSystemObject object, it opens files in one folder and uses the information in it to open specific files in another folder by using the Dir function. For each combination, it prints their names to the immediate window and closes each file without saving changes.
A better way to do this would be to write the file paths of the first folder to an array by using the Dir function and then loop through the elements of the array to open each file... etc.
Option Explicit
Sub PrintTemplatesAndReports()
' Templates
Const tFolderPath As String = "C:\Users\35264\summary\templates\"
Const tWorksheetName As String = "Summary"
Const rFilePatternAddress As String = "A1"
Const tFileExtensionLeft As String = "xls"
' Reports
Const rFolderPath As String = "C:\Users\35264\summary\reports\"
Const rFileExtensionPattern As String = ".xls*"
' 1st Worbook (ThisWorkbook)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(tFolderPath) Then Exit Sub
If Not fso.FolderExists(rFolderPath) Then Exit Sub
Dim fsoFolder As Object: Set fsoFolder = fso.Getfolder(tFolderPath)
' Templates (using the FileSystemObject object)
Dim fsoFile As Object
Dim twb As Workbook, tws As Worksheet
Dim tExtension As String, tFilePath As String
' Report (using Dir)
Dim rwb As Workbook
Dim rFilePattern As String, rFileName As String, rFilePath As String
' Counters
Dim ttCount As Long, tCount As Long, rCount As Long
For Each fsoFile In fsoFolder.Files
ttCount = ttCount + 1
tExtension = fso.GetExtensionName(fsoFile)
If InStr(1, tExtension, tFileExtensionLeft, vbTextCompare) = 1 Then
tCount = tCount + 1
tFilePath = tFolderPath & fsoFile.Name
' 2nd Workbook (Template)
Set twb = Workbooks.Open(tFilePath)
On Error Resume Next
Set tws = twb.Worksheets(tWorksheetName)
On Error GoTo 0
If Not tws Is Nothing Then
rFilePattern = CStr(tws.Range(rFilePatternAddress).Value)
rFileName = Dir(rFolderPath, "*" & rFilePattern _
& "*" & rFileExtensionPattern)
Do Until Len(rFileName) = 0
rCount = rCount + 1
rFilePath = rFolderPath & rFileName
' 3rd Workbook (Report)
Set rwb = Workbooks.Open(rFolderPath, rFileName)
' Do your thing, e.g.:
Debug.Print twb.Name, rwb.Name
rwb.Close SaveChanges:=False
rFileName = Dir ' next report
Loop
Set tws = Nothing
End If
twb.Close SaveChanges:=False
End If
Next fsoFile ' next template
MsgBox "Template files processed: " & tCount & "(" & ttCount & ")" _
& vbLf & "Report files processed: " & rCount & "(" & tCount & ")", _
vbInformation
End Sub
I am really new to VBA and I have just been learning the basics and the VBA language recently from Youtube and communities such as these. Therefore, any help will be really appreciated!
I am trying to consolidate excel worksheets from different excel workbooks into a main excel workbook. The excel workbooks are all found in the same file. However, they are named differently and I only have the partial names for the excel workbooks e.g. "ABG_RSPB_xxxxx-yyyy".
I will have a main workbook in the folder consolidating the data from all the different workbook and worksheets. Each workbook where the data is extracted from only has one worksheet and the template in each worksheet is the same. They have the same headers as well. All the workbooks are csv format. However the worksheets have partial names as well (the worksheet will have the same name as the workbook it is in).
Currently, I have a macro that provides a similar function however, it can't extract workbooks and worksheets with partial names.
Any help to amend the macro such that it can extract from partial workbooks and worksheets will be deeply appreciated. Thank you!
Current code:
Sub consolidation ()
Set mainWB = ActiveWorkbook
Dim mainPath As String
mainPath = ThisWorkbook.Path
Dim mainRowstart As Integer
mainRowstart = 2
Dim mainRC As Integer
mainRC = lastRow ("Consolidated Trades", "A") + 1
If mainRC < mainRowStart Then
mainRC = mainRowStart
EndIf
Dim fso As Object
Dim folder As Object
Dim files As Object
Set fso = CreateObject ("Scripting.FileSystemObject")
Set folderPaths = fso.getfolder (mainPath)
set filePaths = folderPath.files
Dim curFile As String
Dim curPath As String
Dim curRC As Integer
Dim curWSName As String
curWSName = ""
For Each filePath In filePaths
curPath = filePath
curFile = Split (curPath, "\")(UBound(Split(curPath, "\")))
If Left (curFile, 1) <> "~" Then
If curFile <> "ABG_RSPB_xxxxx=yyy.csv" Then
If Right (curFile, Len ("ABG_RSPB_xxxxx=yyy.xlsm")) = "ABG_RSPB_xxxxx=yyy.xlsm" Or _ Right (curFile, Len("ABG_RSPB_xxxxx=yyy.xls")) = "ABG_RSPB_xxxxx=yyy.xls" Then
Workbooks.Open Filename: = curPath
Workbooks (curFile).Activate
For Each ws In Worksheets
If ws.Name = "ABG_RSPB_xxxxx=yyy.csv" Then
curWSName = ws.Name
End If
Next Ws
curRC = lastRow(CurWSName, "A")
mainWB.Activate
mainRC = lastrow("Consolidated Trades", "A") + 1
If curRC >= 2 Then
mainWB.Worksheets("Consolidated Trades").Range("A" & mainRC & ":U: & mainRC + curRC - 2).Value = _ Workbooks(curFile).Worksheets(curWSName).Range("A2:U" & curRC).Value
mainWB.Worksheets("Consolidated Trades").Range("V" & mainRC).Value = curFile & "with" & curRC -1 & "Rows of Data"
EndIf
Workbooks(curFile).Close
EndIf
EndIf
EndIf
NextfilePath
MsgBox "Process Complete"
End Sub
If I've understood you correctly, you have some csv files besides your main workbook and you want to iterate over all csv files and read all values in the first column of the first sheet of each file and then write them into the first column of the main workbook, right?
I've assumed that:
all csv files are desired and should be read (i.e., there is no csv file that you do not want to read it)
You have a subroutine called "lastrow" that finds the last row in a column of a sheet
Please see if the following code does the job correctly. If there is any problem, please leave a comment below, I'll see and edit my code as you want.
Sub consolidation()
Dim mainRowstart As Integer
mainRowstart = 2
Dim mainRC As Integer
mainRC = lastrow("Consolidated Trades", "A") + 1 'I've assumed that you have another sub called "lastrow"
If mainRC < mainRowstart Then
mainRC = mainRowstart
End If
'======================================================================================================
' 1- Get all csv files in this workbook's path
'======================================================================================================
Dim allCsvFiles() As Variant
allCsvFiles = GetFileList(ThisWorkbook.path, "csv")
'======================================================================================================
' 2- Loop over and read/write all data
'======================================================================================================
If IsArray(allCsvFiles) Then 'i.e., at least one file has found
Dim file As Variant
For Each file In allCsvFiles
'Open file
Workbooks.Open (file)
'Activate
Workbooks(file).Activate
'How many rows do exist in the file?
Dim curRC As Integer
curRC = lastrow(Workbooks(file).Sheets(1).Name, "A") 'Hint: as the file is a "csv" file, it always contains only one sheet and there is no need to search and find a specific sheet
If curRC > 2 Then
mainRC = lastrow("Consolidated Trades", "A") + 1 'Is it required to run this function in every iteration???
ThisWorkbook.Worksheets("Consolidated Trades").Range("V" & mainRC).Value = file & " with " & curRC - 1 & " rows of data"
'Read and write data
Dim row As Integer
For row = 2 To curRC
ThisWorkbook.Worksheets("Consolidated Trades").Cells(mainRC, 1).Value = Workbooks(file).Sheets(1).Cells(row, 1).Value
mainRC = mainRC + 1
Next row
End If
'Close file
Workbooks(file).Close False
Next
MsgBox "Process Complete"
End If
End Sub
where GetFileList is:
Function GetFileList(path As String, FileSpec As String) As Variant
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
FileCount = 0
FileName = Dir(path & "\*." & FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
NoFilesFound:
GetFileList = False
End Function
Save batch files as csv from excel.
VBA separates one Excel sheet of data into separate files, after every 833th row.
Now I need these files to be csvs and not Excels. How can I save directly to .csv (separated by comma) files?
I have made appropriate VBA to save into Excel (xml), but not csvs. I need CSVs.
Sub Macro1()
Dim rLastCell As Range
Dim rCells As Range
Dim strName As String
Dim lLoop As Long, lCopy As Long
Dim wbNew As Workbook
With ThisWorkbook.Sheets(1)
Set rLastCell = .Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious)
For lLoop = 1 To rLastCell.Row Step 833
lCopy = lCopy + 1
Set wbNew = Workbooks.Add
.Range(.Cells(lLoop, 1), .Cells(lLoop + 833, .Columns.Count)).EntireRow.Copy _
Destination:=wbNew.Sheets(1).Range("A1")
wbNew.Close SaveChanges:=True, Filename:="Chunk" & lCopy & "Rows" & lLoop & "-" & lLoop + 833
Next lLoop
End With
End Sub
Actual results: Excels
Expected results: CSV files
Something like this?
Sub CSVQuotes()
Dim SrcRange As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSeparator As String
Dim FileName As Variant
Dim current As String
FileName = Application.GetSaveAsFilename()
ListSeparator = ";"
Set SrcRange = Sheets("DATI").UsedRange
Open FileName For Output As #1
For Each CurrRow In SrcRange.Rows
CurrTextStr = ""
For Each CurrCell In CurrRow.Cells
current = CurrCell
CurrTextStr = CurrTextStr & """" & current & """" & ListSeparator
Next
While Right(CurrTextStr, 1) = ListSeparator
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
Print #1, CurrTextStr
Next
Close #1
Assuming:
strPath = path to target folder
autoIncrement = variable to increment every loop (so we can differentiate the files names)
strRow = string representing 1 row in the CSV; concatenate all columns of each Excel row, alternating values with separator (",")
You can output CSV with this inside a loop:
Open strPath & "\file-" & autoIncrement & ".csv" For Output As #fileNumber
Print #fileNumber, strRow
Close #fileNumber
I've been trying to scavange together a macro which will merge several .CSV files.
However, the data I need in said file (GPS data) is located in different rows of column A. I therefor need it to search for part of a string, in this case there are a few strings related to GPS, but I only need GPS latitud and longitude (which will always be found one after another).
Any help is appreciated! The code might look a bit.. like shit, ive been trying to mess with it to make it work together!
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim directory As Object
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim S_Lat, S_Long, D_Lat, D_Long As Range
Dim i As Integer
Dim icount As Integer
Dim icount2 As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then '-1 = yes or true
FolderPath = .SelectedItems(1) & "\"
Else
MsgBox "FilePath not selected!", , "Path selecter"
Exit Sub
End If
End With
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 2
' Call Dir the first time, pointing it to all .csv files in the folder path.
FileName = dir(FolderPath & "*.csv")
SummarySheet.Range("A1") = "Filnamn"
SummarySheet.Range("B1") = "Latitud"
SummarySheet.Range("C1") = "Longitud"
' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & "\" & FileName)
' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName
' Set the source range to be A9 through C9.
' Modify this range for your workbooks.
' It can span multiple rows.
For i = 1 To 200
If InStr(1, LCase(Range("A" & i)), "GPS Latitude") <> 0 Then 'If GPS appears in the string then
icount = i
icount2 = icount + 1
Set S_Lat = WorkBk.Worksheets(1).Range("A" & icount) ' Set the S_Lat variable
Set S_Long = WorkBk.Worksheets(1).Range("A" & icount2) ' Set the S_Long variable
Exit For
End If
Next i
' Set the destination range to start at column B and
' be the same size as the source range.
' SummarySheet.Range("B" & NRow).Value = S_Lat.Value ***** Didnt work? ******
' SummarySheet.Range("C" & NRow).Value = S_Long.Value ***** Didnt work? ******
Set D_Lat = SummarySheet.Range("B" & NRow)
Set D_Long = SummarySheet.Range("C" & NRow)
' Copy over the values from the source to the destination.
D_Lat.Value = S_Lat.Value
D_Long.Value = S_Long.Value
' Increase NRow so that we know where to copy data next.
NRow = NRow + D_Lat.Rows.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = dir()
Loop
' Call AutoFit on the destination sheet so that all
' data is readable.
' SummarySheet.Columns.AutoFit
End Sub
This simple code is not giving you a complete working macro, it will Look for "Latitude" in column A and when found it will transfer the cel.value, and the cel.value below it, to two rows side-by-side in column B and column C on the same worksheet. You will need to wrap it inside your Workbooks.Open loop, modify the Range in the source worksheet to include a last row, include a last row for your new workbook's worksheet and add it to the code inside the If statement. Try to work this into your code and when you encounter problems, you can return to SO and ask a specific question concerning your macro. The macro was tested with actual longitudes and latitudes, in column A, an placed in columns B and C side-by-side.
Dim lRow As Long
lRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For Each cel In Range("A1:A38")
If InStr(1, cel.Value, "Latitude") Then
x = x + 1
Cells(x, 2).Value = cel.Value
Cells(x, 3).Value = cel.Offset(1).Value
End If
Next cel
I have some csv files in one folder. They all contain 3 specific columns. The number of total columns and the order may vary.
I want to concatenate all 3 columns with an underscore and write them in a single column in the worksheet that is running the code.
Here is what I have so far:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Cells(i, 1) = Cells(i, Columns(0)) & "_" & Cells(i, Columns(1)) & "_" & Cells(i, Columns(2))
Next i
End Sub
As you can see, this does what I want, but only for the active sheet.
I actually want to loop through all csv files in the same folder as the active sheet and write the results in the first sheet, first column of the sheet running the code (which is not a csv itself obviously).
How can I do this?
thanks!
This is a code that will loop through a folder
Sub Button1_Click()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\WorkBookLoop\"
MyFile = Dir(MyDir & "*.xls") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
'do something here
MyFile = Dir()
Loop
End Sub
It depends how you are naming the worksheets you create from the CSV files. You could add all the worksheets to a collection and use a For...Each loop to execute the entire search and concatenate procedure within that loop. Note that you'd have to explicitly define the first sheet name as this won't change through successive loops:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Dim frontSheet as Worksheet
Dim wSheets as New Collection
Dim ws as Worksheet
Set frontSheet = Sheets("name of front sheet")
'Add all your CSV sheets to wSheets using the .Add() method.
For Each ws in wSheets
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = ws.Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
frontsheet.Cells(i, 1) = ws.Cells(i, Columns(0)) & "_" & ws.Cells(i, Columns(1)) & "_" & ws.Cells(i, Columns(2))
Next i
Next ws
End Sub
It's often slow and labourious to open CSV files in excel but VBA can read them as text files using a TextStream. Furthermore, file scripting objects let you work with files and directories directly. Something like this might be a better approach if you don't need to keep the files in a worksheet afterwards:
Sub SearchFoldersForCSV()
Dim fso As Object
Dim fld As Object
Dim file As Object
Dim ts As Object
Dim strPath As String
Dim lineNumber As Integer
Dim lineArray() As String
Dim cols() As Integer
Dim i As Integer
Dim frontSheet As Worksheet
Dim frontSheetRow As Integer
Dim concatString As String
Set frontSheet = Sheets("name of front sheet")
frontSheetRow = 1
strPath = "C:\where-im-searching\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
For Each file In fld.Files
If (Right(file.Name, 3) = "csv") Then
Debug.Print file.Name
Set ts = file.OpenAsTextStream()
lineNumber = 0
Do While Not ts.AtEndOfStream
lineNumber = lineNumber + 1
lineArray = Split(ts.ReadLine, ",")
If (lineNumber = 1) Then
'We are at the first line of the .CSV so
'find index in lineArray of columns of interest
'Add extra ElseIf as required
For i = LBound(lineArray) To UBound(lineArray)
If lineArray(i) = "Column 1" Then
cols(1) = i
ElseIf lineArray(i) = "Column 2" Then
cols(2) = i
ElseIf lineArray(i) = "Column 3" Then
cols(3) = i
End If
Next i
Else
'Read and store the column of interest from this
'row by reading the lineArray indices found above.
concatString = ""
For i = LBound(cols) To UBound(cols)
concatString = concatString & lineArray(i) & "_"
Next i
concatString = Left(concatString, Len(concatString) - 1)
frontSheet.Cells(frontSheetRow, 1).Value = concatString
frontSheetRow = frontSheetRow + 1
End If
Loop
ts.Close
End If
Next file
End Sub
You can find more information on FileSystemObject and TextStream here.