I'm trying to create a CSV output file in VBA but I can't seem to get it. I need to loop through a spreadsheet and pull numbers from column 'I' based on whether column D has a "1" in it or not. Then I want to paste the contents of column 'I' into column 'A' of the CSV output file. Could someone please help me complete this? I'd like to incorporate all of the following:
Sub Test()
Dim FileNum, bOutputLine, bFile As String
Dim bOUTPUT, iRow As Integer
bOUTPUT = FreeFile 'Define bOUTPUT as a FreeFile
bFile = "C:\Desktop\Test.csv" 'set the filepath equal to a string
For iRow = 2 To ActiveSheet.UsedRange.Rows.Count
If Trim(range("D" & iRow)) <> "" Then
FileNum = Trim(range("I" & iRow))
End If
Next
Open bFile For Output As bOUTPUT 'Open the file
bOutputLine = FileNum
Print #bOUTPUT, bOutputLine
Close #bOUTPUT 'Close the file
End Sub
You either need to put the file interaction inside the for-next loop and open as append instead of output, or build a string variable in the loop that will print out at the bottom. Here's the two options:
Sub Test()
Dim FileNum, bOutputLine, bFile As String
Dim bOUTPUT, iRow As Integer
bOUTPUT = FreeFile 'Define bOUTPUT as a FreeFile
bFile = "C:\Users\HPUser\Desktop\Test.csv" 'set the filepath equal to a string
Open bFile For Append As bOUTPUT 'Open the file
For iRow = 2 To ActiveSheet.UsedRange.Rows.Count
If Trim(range("D" & iRow)) <> "" Then
FileNum = Trim(range("I" & iRow))
bOutputLine = FileNum
Print #bOUTPUT, bOutputLine
End If
Next
Close #bOUTPUT 'Close the file
End Sub
or
Sub Test()
Dim FileNum, bOutputLine, bFile As String
Dim bOUTPUT, iRow As Integer
bOUTPUT = FreeFile 'Define bOUTPUT as a FreeFile
bFile = "C:\Users\HPUser\Desktop\Test.csv" 'set the filepath equal to a string
For iRow = 2 To ActiveSheet.UsedRange.Rows.Count
If Trim(range("D" & iRow)) <> "" Then
bOutputLine = bOutputLine & Trim(range("I" & iRow)) & vbcrlf
End If
Next
Open bFile For Output As bOUTPUT 'Open the file
Print #bOUTPUT, bOutputLine
Close #bOUTPUT 'Close the file
End Sub
One way is to write to it directly in the loop:
Open bFile For Output As bOUTPUT
For iRow = 2 To ActiveSheet.UsedRange.Rows.Count
If InStr(1, Range("D" & iRow), "1") <> 0 Then
Print #bOUTPUT, Trim(Range("I" & iRow))
End If
Next
Close #bOUTPUT
The InStr will look for the value "1" in Column D's cell (as by the wording of the question, it seems it could be something like "AAA1A". It returns 0 if "1" is not found.
Related
I have a piece of VBA code written that allows user to export table to CSV format (comma separated). Unfortunately one of the columns includes commas in values what breaks the structure when user separating columns by delimiter in excel.
I would not like to write anything from scratch so I was trying and looking for some ways to incorporate text identifiers into my code, but unfortunately found nothing.
Sub save_to_csv()
'Defininf variables
Dim tbl As ListObject
Dim ws As Worksheet
Dim csvFilePath As String
Dim fNum As Integer
Dim tblArr
Dim rowArr
Dim csvVal
Dim row
Dim Fldr As String
Dim CurrTS As String
Set ws = Worksheets("Slot_booking_table")
Set objList = ws.ListObjects("Slot_booking_table")
'Current timestamp variable to identify saved CSV files
CurrTS = CStr(Format(DateTime.Now, "yyyy_MM_dd_hh_mm_ss"))
'File dialog to select location where CSV file should be saved
With Application.FileDialog(4)
.AllowMultiSelect = False
.Title = "Select location to save CSV file"
If .Show <> -1 Then Exit Sub
Fldr = .SelectedItems(1)
End With
'Generating CSV file name
csvFilePath = Fldr & "\slot_booking_" & CurrTS & ".csv"
'Loading table to two-dimensional array
tblArr = objList.Range.Value
'Loop for joining each row from array by delimiter
fNum = FreeFile()
Open csvFilePath For Output As #fNum
For i = 1 To UBound(tblArr)
rowArr = Application.Index(tblArr, i, 0)
csvVal = VBA.Join(rowArr, ",")
Print #1, csvVal
Next
Close #fNum
MsgBox "CSV file has been generated. Please check the selected location."
Set tblArr = Nothing
Set rowArr = Nothing
Set csvVal = Nothing
End Sub
I tried to add For Each loop but it does not help:
Sub save_to_csv()
'Defininf variables
Dim tbl As ListObject
Dim ws As Worksheet
Dim csvFilePath As String
Dim fNum As Integer
Dim tblArr
Dim rowArr
Dim csvVal
Dim row
Dim Fldr As String
Dim CurrTS As String
Set ws = Worksheets("Slot_booking_table")
Set objList = ws.ListObjects("Slot_booking_table")
'Current timestamp variable to identify saved CSV files
CurrTS = CStr(Format(DateTime.Now, "yyyy_MM_dd_hh_mm_ss"))
'File dialog to select location where CSV file should be saved
With Application.FileDialog(4)
.AllowMultiSelect = False
.Title = "Select location to save CSV file"
If .Show <> -1 Then Exit Sub
Fldr = .SelectedItems(1)
End With
'Generating CSV file name
csvFilePath = Fldr & "\slot_booking_" & CurrTS & ".csv"
'Loading table to two-dimensional array
tblArr = objList.Range.Value
'Loop for joining each row from array by delimiter
fNum = FreeFile()
Open csvFilePath For Output As #fNum
For i = 1 To UBound(tblArr)
rowArr = Application.Index(tblArr, i, 0)
For Each row In rowArr
row = """ & row & """
Next row
csvVal = VBA.Join(rowArr, ",")
Print #1, csvVal
Next
Close #fNum
MsgBox "CSV file has been generated. Please check the selected location."
Set tblArr = Nothing
Set rowArr = Nothing
Set csvVal = Nothing
End Sub
Is there a way to incorporate line with adding text identifier into my code without changing the part of code with joining arrays by delimiter?
It might help to use write instead of print
The documentation to write states:
Unlike the Print # statement, the Write # statement inserts commas
between items and quotation marks around strings as they are written
to the file.
Please, try replacing this part of your code:
Open csvFilePath For Output As #fNum
For i = 1 To UBound(tblArr)
rowArr = Application.Index(tblArr, i, 0)
For Each row In rowArr
row = """ & row & """
Next row
csvVal = VBA.Join(rowArr, ",")
Print #1, csvVal
Next
Close #fNum
with this one:
Dim j As Long, strLine As String, strText As String 'the other variables were declared already...
For i = 1 To UBound(tblArr)
For j = 1 To UBound(tblArr, 2)
strLine = strLine & Chr(34) & tblArr(i, j) & Chr(34) & "," 'build the line string
Next
strLine = left(strLine, Len(strLine) - 1) & vbCrLf 'replace the last comma with end of line
strText = strText & strLine 'add the line to the whole string to be used
strLine = "" 'reinitialize the line variable
Next i
strText = left(strText, Len(strText) - 1) 'replace the ending end of line
fNum = FreeFile()
Open csvFilePath For Output As #fNum
Print #fNum, strText 'place the string at once
Close #fNum
I am currently working in vb.net. My company is going paperless and I want to do a cost saving analysis on paper savings. Currently we save all of our PDF files onto a server. The file path is like this "Server>Folder1>Folder2>Folder3>Folder4>PDF files." Folders 1 and 2 are always used to navigate through. Folder 3 is a list of departments, and folder 4 is each job. Each folder 4 has multiple pdf files. To be put simply the names of Folder 1 and Folder 2 are static while folders 3 and 4 are dynamic. To make things even harder all of the PDF files located after folder 4 have different names. I have the bit of code below to detect how many pages a pdf is without having to open it but it requires the file pathway. Considering there are hundreds if not over a thousand pdf files I want to programmatically loop through all of these files, detect if the file is a pdf file, then sum all of the pages that are found. I can then use that number to calculate cost savings of going paperless.
PdfReader pr = new PdfReader("/path/to/yourFile.pdf");
return pr.getNumberOfPages();
Another idea would be to somehow merge all the files togther into a single PDF file which would make it as simple as opening the file to see how many pages are there.
Here is a VBA solution. Run the code in Excel.
Sub PDFandNumPages()
Dim Folder As Object
Dim file As Object
Dim fso As Object
Dim iExtLen As Integer, iRow As Integer
Dim sFolder As String, sExt As String
Dim sPDFName As String
sExt = "pdf"
iExtLen = Len(sExt)
iRow = 1
' Must have a '\' at the end of path
sFolder = "C:\your_path_here\"
Set fso = CreateObject("Scripting.FileSystemObject")
If sFolder <> "" Then
Set Folder = fso.GetFolder(sFolder)
For Each file In Folder.Files
If Right(file, iExtLen) = sExt Then
Cells(iRow, 1).Value = file.Name
Cells(iRow, 2).Value = pageCount(sFolder & file.Name)
iRow = iRow + 1
End If
Next file
End If
End Sub
Function pageCount(sFilePathName As String) As Integer
Dim nFileNum As Integer
Dim sInput As String
Dim sNumPages As String
Dim iPosN1 As Integer, iPosN2 As Integer
Dim iPosCount1 As Integer, iPosCount2 As Integer
Dim iEndsearch As Integer
' Get an available file number from the system
nFileNum = FreeFile
'OPEN the PDF file in Binary mode
Open sFilePathName For Binary Lock Read Write As #nFileNum
' Get the data from the file
Do Until EOF(nFileNum)
Input #1, sInput
sInput = UCase(sInput)
iPosN1 = InStr(1, sInput, "/N ") + 3
iPosN2 = InStr(iPosN1, sInput, "/")
iPosCount1 = InStr(1, sInput, "/COUNT ") + 7
iPosCount2 = InStr(iPosCount1, sInput, "/")
If iPosN1 > 3 Then
sNumPages = Mid(sInput, iPosN1, iPosN2 - iPosN1)
Exit Do
ElseIf iPosCount1 > 7 Then
sNumPages = Mid(sInput, iPosCount1, iPosCount2 - iPosCount1)
Exit Do
' Prevent overflow and assigns 0 to number of pages if strings are not in binary
ElseIf iEndsearch > 1001 Then
sNumPages = "0"
Exit Do
End If
iEndsearch = iEndsearch + 1
Loop
' Close pdf file
Close #nFileNum
pageCount = CInt(sNumPages)
End Function
Here is an alternative way of doing essentially the same thing.
Sub Test()
Dim MyPath As String, MyFile As String
Dim i As Long
MyPath = "C:\your_path_here\"
MyFile = Dir(MyPath & Application.PathSeparator & "*.pdf", vbDirectory)
Range("A:B").ClearContents
Range("A1") = "File Name": Range("B1") = "Pages"
Range("A1:B1").Font.Bold = True
i = 1
Do While MyFile <> ""
i = i + 1
Cells(i, 1) = MyFile
Cells(i, 2) = GetPageNum(MyPath & Application.PathSeparator & MyFile)
MyFile = Dir
Loop
Columns("A:B").AutoFit
MsgBox "Total of " & i - 1 & " PDF files have been found" & vbCrLf _
& " File names and corresponding count of pages have been written on " _
& ActiveSheet.Name, vbInformation, "Report..."
End Sub
'
Function GetPageNum(PDF_File As String)
'Haluk 19/10/2008
Dim FileNum As Long
Dim strRetVal As String
Dim RegExp
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
FileNum = FreeFile
Open PDF_File For Binary As #FileNum
strRetVal = Space(LOF(FileNum))
Get #FileNum, , strRetVal
Close #FileNum
GetPageNum = RegExp.Execute(strRetVal).Count
End Function
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 6 years ago.
Improve this question
I am trying to make a macro that will bulk perform on all .txt files in a given directory. I would like the first line to be copied into the first cell (A1). And then I would like the rest of the contents to be pasted into B1.
The macro would perform that for all the .txt files in a directory, except it would go to A2, B2...A3,B3 etc
Can anyone help?
This should work for you:
Sub Mrig_GettxtData()
Dim strFile As String, strPath As String, MyData As String, tempStr As String
Dim filePath As Variant
Dim strData() As String
Dim lineNo As Long
Dim myCell As Range
strPath = "C:\test_folder\test" '--> write your path here (without "\")
filePath = strPath & "\"
Set myCell = ThisWorkbook.Sheets("Sheet1").Range("A1") '-->change Sheet1 as required
strFile = Dir(filePath & "*.txt")
Do While Len(strFile) > 0
Open filePath & strFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
lineNo = 0
tempStr = ""
For Each a In strData
lineNo = lineNo + 1
If lineNo = 1 Then 'tempStr = "" Then
myCell.Value = a
Set myCell = myCell.Offset(0, 1)
ElseIf lineNo = 2 Then
tempStr = a
Else
tempStr = tempStr & vbCrLf & a
End If
Next
If lineNo <> 1 Then
myCell.Value = tempStr
Set myCell = myCell.Offset(1, -1)
End If
strFile = Dir()
Loop
End Sub
Try this. This will iterate through all the ".txt" files in a folder "in this case it is "H:\data\" in alphabetical order. Any blank text files will be skipped. The first two rows will be populated of the first sheet (or tab) of the workbook where the macro is saved.
Sub readLine()
Dim FileNum As Integer
Dim DataLine As String
Dim strTXTFile As String, strFileSpec As String
strFileSpec = "*.txt"
strFilePath = "D:\data\"
'set starting rng where data will be saved
Set Rng = ThisWorkbook.Sheets(1).Range("A1")
strTXTFile = Dir(strFilePath & strFileSpec)
Do While strTXTFile <> ""
ILine = 1
FileNum = FreeFile()
Open strFilePath & strTXTFile For Input As #FileNum
If EOF(FileNum) Then GoTo skipFile
Line Input #FileNum, DataLine 'save the first line of the document into variable DataLine
Rng.Value = DataLine
Do Until EOF(FileNum)
Line Input #FileNum, DataLine 'save the first line of the document into variable DataLine
Rng.Offset(, 1).Value = Rng.Offset(, 1).Value & DataLine
Loop
Set Rng = Rng.Offset(1)
skipFile:
Close #FileNum
strTXTFile = Dir
Loop
End Sub
I'm generating a tsv file from a macro but the data contains special characters like the 'tm' symbol and this in turn will be fed into a mysqlimport in the server. But because of the special characters it doesn't load the rest of the string after the special character.
I have the following macro to save it to my preffered delimiter and enclosure
But now I want to specify the encoding I want to save the file in as well.
How would I go about this?
Sub tsv()
Dim SrcRg As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim FName As Variant
FName = Application.GetSaveAsFilename("", "TSV File (*.tsv), *.tsv")
'FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")
'assign the character delimiter you want
ListSep = Chr(9)
'ListSep = "|"
'assign the enclosure character you want
ListEnc = "^"
If Selection.Cells.Count > 1 Then
Set SrcRg = Selection
Else
Set SrcRg = ActiveSheet.UsedRange
End If
Open FName For Output As #1
For Each CurrRow In SrcRg.Rows
CurrTextStr = ""
For Each CurrCell In CurrRow.Cells
CurrTextStr = CurrTextStr & ListEnc & CurrCell.Value & ListEnc & ListSep
Next
While Right(CurrTextStr, 1) = ListSep
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
Print #1, CurrTextStr
Next
Close #1
End Sub
Use an ADODB stream object.
Set BS = CreateObject("ADODB.Stream")
'2 = text so use writetext rather than 1 = binary and use write
BS.type = 2
'Get the list of chartypes by typing in a command prompt ***reg query HKEY_CLASSES_ROOT\MIME\Database\Charset***
BS.Charset = "UTF-8"
BS.open
BS.WriteText "Hi kiddies"
'A=Array(CByte("M"),CByte("Z"))
'BS.Write A
BS.SaveToFile "c:\myfile.txt", 2
So on my "sheet1" I have data in columns A, B, C, D, E, F
I would like VBA code to combine the 1st (A), 3rd(C) and 5th (E) column and save it to a comma separated text file.
I have:
Option Explicit
Public Sub ExcelRowsToCSV()
Dim iPtr As Integer
Dim sFileName As String
Dim intFH As Integer
Dim aRange As Range
Dim iLastColumn As Integer
Dim oCell As Range
Dim iRec As Long
Dim lenth As String
Set aRange = Range("A1:C11")
iLastColumn = aRange.Column + aRange.Columns.Count - 1
iPtr = InStrRev(ActiveWorkbook.FullName, ".")
sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".txt"
sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="TXT (Comma delimited) (*.txt), *.txt")
If sFileName = "False" Then Exit Sub
Close
intFH = FreeFile()
Open sFileName For Output As intFH
iRec = 0
For Each oCell In aRange
If oCell.Column = iLastColumn Then
Print #intFH, oCell.Value
iRec = iRec + 1
Else
Print #intFH, oCell.Value; ",";
iRec = iRec + 1
End If
Next oCell
Close intFH
MsgBox "Finished: " & CStr(iRec) & " records written to " _
& sFileName & Space(10), vbOKOnly + vbInformation
End Sub
This works but only if the range declared has columns that lay right next to each other.
The fastest way is to copy the worksheet as a new workbook and then delete unnecessary columns and then save the file as csv. This will not affect the original file as well.
For example (TRIED AND TESTED)
Option Explicit
Sub Sample()
Dim wb As Workbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Copy the sheet as a new workbook
ws.Copy
ActiveSheet.Range("D:D,B:B,F:F").Delete Shift:=xlToLeft
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:\Sample.Csv", FileFormat:=xlCSV
ActiveWorkbook.Close (False)
Application.DisplayAlerts = True
End Sub
try changing your for each to this: (untested, but hope you get the idea)
dim str as string
For i= 1 to arange.rows
str=""
for j=1 to arange.columns
str=str & ","
next
Print #intFH, str
Next