I'm trying to use the below saveas() function to output an excel worksheet to a xltext file. the file is generated fine but numbers with a special formatting of #,###.00. are output as "1,000.00" rather than just 1,000.00. How can I remove these double quotes.
Dim tab_output_line, tab_output_head, tab_source As String
Dim File_Location As String
tab_output_line = "Upload_PO_LineItem"
tab_source = "PBOOK"
File_Location = Sheets(tab_source).Range("S5").Value
Sheets(tab_output_line).Select
ChDir File_Location
ActiveWorkbook.SaveAs Filename:= _
File_Location + tab_output_line + ".txt", FileFormat:=xlText, _
CreateBackup:=False
Your current code is making a tab-delimited file. Cells that contain commas (even as formatted) are being "protected" by being enclosed in double quotes.
To avoid this "protection", try code like this:
Sub tony2()
Dim N As Long, i As Long, j As Long, Record As String
Dim M As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
Close #2
Open "C:\Users\Garys\desktop\tony.txt" For Output As #2
For i = 1 To N
Record = ""
M = Cells(i, Columns.Count).End(xlToLeft).Column
For j = 1 To M
Record = Record & vbTab & Cells(i, j).Text
Next j
Record = Mid(Record, 2)
Print #2, Record
Next i
Close #2
End Sub
Input:
and output:
Related
I would like to print a range of date into .txt file with some special header so that a special software called Prophet could recognize.
Sub Export_TEST()
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer
Dim prophetheader As String
Dim prophetlineheader As String
myFile = Application.DefaultFilePath & "\" & "test" & ".txt"
Set rng = Selection
prophetheader = "!1"
Open myFile For Output As #1
Print #1, rng.Columns.Count - 1
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
ElseIf i = 1 And j = 1 Then
Print #1, prophetheader, cellValue,
ElseIf j = 1 Then
Print #1, "*", cellValue,
Else
Print #1, cellValue,
End If
Next j
Next i
Close #1
End Sub
The code is quite straight forward, just add * in the front of each line and add !1 in the column header. But I encounter the issue that the output file has been delimited using comma and no double quotation in the string. And I am in the dilemma that if I use write function, it will use comma as delimiter, but has double quotation on string and if I use Print, space as delimiter and no double quote on string.
Is there a way to print the file using comma delimiter and no double quote on string?
Below is the dummy data selection.
SPCODE NAME
1 JS
And the output should be
21
!1,SPCODE,NAME
*,1,JS
Maybe instead of writing each single row to the text file you just write each line in total like that
Option Explicit
Sub Export_TEST()
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer
Dim prophetheader As String
Dim prophetlineheader As String
myFile = ThisWorkbook.Path & "\" & "test" & ".txt"
Set rng = Selection
prophetheader = "!1"
Open myFile For Output As #1
Print #1, rng.Columns.Count - 1
Dim line As String
For i = 1 To rng.Rows.Count
line = ""
For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If j = rng.Columns.Count Then
line = line & cellValue & ","
ElseIf i = 1 And j = 1 Then
line = line & prophetheader & cellValue & ","
ElseIf j = 1 Then
line = line & "*" & cellValue & ","
Else
line = line & cellValue & ","
End If
Next j
line = Left(line, Len(line) - 1)
Print #1, line
Next i
Close #1
End Sub
So I have a huge CSV file that has to be transposed before loading into an Excel spreadsheet (due to Excel 2010 limitations). This code seemed to do the trick until the file got big (>30mb).
Sub transpose_delimited_file(sheet, filename, skip_columns, delimiter)
Dim temp As String
Dim i As Long, x
temp = CreateObject("Scripting.FileSystemObject").OpenTextFile(filename, 1).ReadAll
x = Split(temp, vbCrLf): temp = ""
For i = 0 To UBound(x) - 1
y = Split(x(i), delimiter)
ThisWorkbook.Sheets(sheet).Cells(1, i + 1 + skip_columns).Resize(UBound(y) + 1).Value = _
Application.Transpose(y)
Next
So how can the above code be changed to avoid an out of memory error? Is there a way to change the ReadAll to just read X number of lines at a time then transpose and paste in the worksheet to keep the memory free? Much appreciated.
The best attempt is to read the file line by line and paste them as columns in the destination sheet. The following code using raw I/O should achieve it:
Sub transposeDelimitedFile(ByRef sh As Worksheet, ByVal fName As String, _
Optional ByVal startCol As Long = 1, _
Optional ByVal delim As String = ",")
Dim sLine As String, ar
Open fName For Input As #1
Do Until EOF(1)
Line Input #1, sLine
ar = Split(sLine, delim)
sh.Columns(startCol).Resize(UBound(ar) + 1).value = Application.Transpose(ar)
startCol = startCol + 1
Loop
Close #1
End Sub
Sub Test()
transposeDelimitedFile Worksheets("Sheet1"), "C:\SO\SO.CSV", 6, ","
End Sub
I have more than 100 excel files in .xlsx extension, Columns in all the files are not in order, i would like to re-arrange the Column order as per my Template and i would like to append the data from all files into one Output file.
i have tried the solution in this link Rearranging Columns in Multiple Excel Files using VBA and it did not work.
below are the sample files Headings for reference.
File1
Heading1,Heading2,Heading3
File2
Heading2,Heading1,Heading5,Heading7
Template File
Heading1,Heading2,Heading3,Heading4,Heading5,Heading6,Heading7
Expected Output File
FileName,Heading1,Heading2,Heading3,Heading4,Heading5,Heading6,Heading7
Try the below.
Sub Order_Columns()
Dim template_headers As Variant, header As Variant, current_header As Variant, cl As Range, col As Integer
template_headers = Array("Heading1", "Heading2", "Heading3", "Heading4", "Heading5")
For header = LBound(template_headers) To UBound(template_headers)
current_header = template_headers(header)
col = col + 1
Set cl = ActiveSheet.Rows(1).Find(What:=current_header, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not cl Is Nothing Then
If Not cl.Column = col Then
Columns(cl.Column).Cut
Columns(col).Insert Shift:=xlToRight
End If
End If
Next header
End Sub
Specify your desired header order in the array
Note that headers are case-sensitive so maybe use LCase()?
I will leave with you to add code to loop over your 100+ folders to do this and then place that data in your master sheet!
Assuming that in every file you're working on sheet(1)
this would do the job:
Option Explicit
Sub ColumnMover()
Dim i As Integer, j As Integer, k As Integer, m As Integer, n As Integer
Dim mDirs As String
Dim path As String
Dim OutFile As Variant, SrcFile As Variant
Dim MyObj As Object, MySource As Object, file As Variant
OutFile = ActiveWorkbook.Name
mDirs = "c:\" 'your path here with \ in the end
file = Dir(mDirs)
While (file <> "")
path = mDirs + file
Workbooks.Open (path)
SrcFile = ActiveWorkbook.Name
n = 2
While Workbooks(OutFile).Sheets(1).Cells(n, 1).Value <> ""
n = n + 1
Wend
i = 2
While (Workbooks(OutFile).Sheets(1).Cells(1, i).Value <> "")
k = n
j = 1
While Workbooks(SrcFile).Sheets(1).Cells(1, j).Value <> Workbooks(OutFile).Sheets(1).Cells(1, i).Value And _
Workbooks(SrcFile).Sheets(1).Cells(1, j).Value <> ""
j = j + 1
Wend
If Workbooks(SrcFile).Sheets(1).Cells(1, j).Value = Workbooks(OutFile).Sheets(1).Cells(1, i).Value Then
m = 2
While Workbooks(SrcFile).Sheets(1).Cells(m, j).Value <> ""
Workbooks(OutFile).Sheets(1).Cells(k, 1).Value = path
Workbooks(OutFile).Sheets(1).Cells(k, i).Value = Workbooks(SrcFile).Sheets(1).Cells(m, j).Value
k = k + 1
m = m + 1
Wend
End If
i = i + 1
Wend
Workbooks(file).Close (False)
file = Dir
Wend
End Sub
EDIT:
Some explanation:
here the template file and the output file are the same. So first you have to have an xlsm with the structure on sheet(1):
FileName,Heading1,Heading2,Heading3,Heading4,Heading5,Heading6,Heading7
then enter the given code into this file, and run it when the output file is the active sheet.
I am using the code below to generate the single file for selected range and considering the first cell in the selected range as file name. Please find the image below for more details[This image shows the selected range,Consider K column(Firstline) and N Column( Lastline) to be in one file and other set of 1st and last line in other file ]this image shows the print file for a single file this is the way m currently using for generating files.I need to create more 30k files so please help me to create more files in single click considering the first and last line as header and footer for the file
Private Sub CommandButton1_Click()
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer, path As String, filename, filename2 As String
path = "D:\Watchlist-Files\"
filename = Selection.Cells(1, 1).Value
filename2 = Left(Mid(filename, 32, 99), Len(Mid(filename, 32, 99)) - 2)
myFile = path & filename2
Set rng = Selection
Open myFile For Output As #1
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
Else
Print #1, cellValue,
End If
Next j
Next i
Close #1
End Sub
The code below is using a Loop that scans rows in a range that consists of Columns K:N (according to your attached screen-shots).
Assumptions made: your FirstLine is in Column K, and it's the marker of the start position of copying the first cell in the first row.
Your LastLine is in Column N, and it's the marker of the last cell to copy, this is why I am closing the file once it is found.
Edit 1: added a Msgbox to allow the user selection of exporting the entire range or not. In case the user selected NO, then a second InputBox appears that allows the user to enter manually the last row number to export.
Option Explicit
Public Sub CommandButton1_Click()
Dim myFile As String
Dim rng As Range
Dim cellValue As Variant
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim path As String
Dim filename As String
Dim response As Boolean
path = "D:\Watchlist-Files\"
response = MsgBox("Do you want to Export the entire Range ? ", vbYesNo)
' Export the entire Range
If response = vbYes Then
LastRow = Cells(Rows.Count, "N").End(xlUp).Row
Else ' enter in the inputbox the last row number you want to export
LastRow = InputBox("Enter Last Row Number you wsnt to Export")
End If
Set rng = Range("K2:N" & LastRow)
For i = 2 To LastRow
' Column K holds the file name
If Cells(i, 11) <> "" Then
filename = Left(Mid(Cells(i, 11).Value, 32, 99), Len(Mid(Cells(i, 11).Value, 32, 99)) - 2)
myFile = path & filename
Open myFile For Output As #1
End If
For j = 1 To rng.Columns.Count
cellValue = Cells(i, 10 + j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
' found LastLine >> close the file
If Not cellValue = "" Then
Close #1
End If
Else
Print #1, cellValue,
End If
Next j
Next i
End Sub
Edit 2: Added new code below (to keep the first option valid). The user needs to confirm that every selection he makes start and ends with FirstLine and LastLine , there is no error handling.
Option Explicit Section
Option Explicit
Dim filename As String
Dim path As String
Dim myFile As String
Dim rng As Range
Dim j As Long
Public Sub CommandButton1_Click
Public Sub CommandButton1_Click()
Dim lastRow As Long
Dim Sel_Range As Long
Dim response As Boolean
Dim rowStart() As Long
Dim rowFinish() As Long
path = "D:\Watchlist-Files\"
response = MsgBox("Do you want to Export only the Selected Range ? ", vbYesNo)
If response = True Then
Set rng = Selection
ReDim rowStart(1 To Selection.Areas.Count)
ReDim rowFinish(1 To Selection.Areas.Count)
For Sel_Range = 1 To Selection.Areas.Count
rowStart(Sel_Range) = Selection.Areas(Sel_Range).Row
rowFinish(Sel_Range) = Selection.Areas(Sel_Range).Row + Selection.Areas(Sel_Range).Rows.Count - 1
Call CreateTextFiles(rowStart(Sel_Range), rowFinish(Sel_Range))
Next Sel_Range
Else ' export the entire Range in Columns K:N
lastRow = Cells(Rows.Count, "N").End(xlUp).Row
Set rng = Range("K2:N" & lastRow)
Call CreateTextFiles(2, lastRow)
End If
Sub CreateTextFiles(Sel_StartRow As Long, Sel_FinishRow As Long) - new routine to allow handling of multiple Ranges selection
Sub CreateTextFiles(Sel_StartRow As Long, Sel_FinishRow As Long)
Dim i As Long
Dim cellValue As Variant
For i = Sel_StartRow To Sel_FinishRow
' Column K holds the file name
If Cells(i, 11) <> "" Then
filename = Left(Mid(Cells(i, 11).Value, 32, 99), Len(Mid(Cells(i, 11).Value, 32, 99)) - 2)
myFile = path & filename
Open myFile For Output As #1
End If
For j = 1 To rng.Columns.Count
cellValue = Cells(i, 10 + j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
' found LastLine >> close the file
If Not cellValue = "" Then
Close #1
End If
Else
Print #1, cellValue,
End If
Next j
Next i
End Sub
I'm working on a 5 sheet workbook, where a button named ExportCSV on sheet 5 exports data on sheet 3. More specifically, the button runs a VBA code that goes row by row and checks the first 3 cells for data. If any of the first three cells have data, then the whole row is selected. After all rows with data are selected, the data is written row by row to a CSV file (the file itself is semicolon-delimited, however).
The problem that I'm having is that some cell formatting is being copied over, but some is not. For example, values in cells formatted for Accounting with a $ are formatted correctly, meaning "$12,345,678.90" shows up as "$12,345,678.90." However, values in cells formatted as Accounting but without $ are not being written to the csv correctly, meaning "12,345,678.90" is being written as "12345678.9."
Below is the Macro in question.
Dim planSheet As Worksheet
Dim temSheet As Worksheet
Private Sub ExportCSV_Click()
Dim i As Integer
Dim j As Integer
Dim lColumn As Long
Dim intResult As Integer
Dim strPath As String
On Error GoTo Errhandler
Set temSheet = Worksheets(3)
i = 2
Do While i < 1001
j = 1
Do While j < 4
If Not IsEmpty(temSheet.Cells(i, j)) Then
temSheet.Select
lColumn = temSheet.Cells(2, Columns.Count).End(xlToLeft).Column
temSheet.Range(temSheet.Cells(2, 1), temSheet.Cells(i, lColumn)).Select
End If
j = j + 1
Loop
i = i + 1
Loop
Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = Application.ActiveWorkbook.Path
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select a Path"
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Path"
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
If intResult <> 0 Then
'dispaly message box
strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End If
Dim X As Long, FF As Long, S() As String
ReDim S(1 To Selection.Rows.Count)
For X = 1 To Selection.Rows.Count
S(X) = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(Selection.Rows(X).Value)), ";")
Next
FF = FreeFile
FilePath = strPath & "\Data" & Format(Now(), "yyyyMMddhhmmss") & ".csv"
Open FilePath For Output As #FF
Print #FF, Join(S, vbNewLine)
Close #FF
Errhandler:
...Error Handling Code omitted
End Sub
I need to be able to copy over the exact formatting of the cells. Converting the no-$ cells to $ cells won't work because the values without $ are being used for a calculation later on in the process that can handle the commas, but not a $, and I can't change the code for the later calculation (proprietary plug-in doing the calculation.) Also, the rows have mixed content, meaning some values in the row are text instead of numbers.
I ended up following David Zemens' advice and overhauled the section that was For X = 1 to Selection.Rows.Count See below.
For X = 1 To Selection.Rows.Count
For Y = 1 To Selection.Columns.Count
If Y <> Selection.Columns.Count Then
If IsNumeric(temSheet.Cells(X + 1, Y).Value) Then
If temSheet.Cells(X + 1, Y).Value = 0 Then
S(X) = S(X) & ";"
Else
S(X) = S(X) & Replace(temSheet.Cells(X + 1, Y).Text, " ", "") & ";"
End If
Else
S(X) = S(X) & Trim(temSheet.Cells(X + 1, Y).Text) & ";"
End If
Else
If IsNumeric(temSheet.Cells(X + 1, Y).Value) Then
If temSheet.Cells(X + 1, Y).Value <> 0 Then
S(X) = S(X) & Replace(temSheet.Cells(X + 1, Y).Text, " ", "")
End If
Else
S(X) = S(X) & Trim(temSheet.Cells(X + 1, Y).Text)
End If
End If
Next
Next
Some more formatting was necessary. It goes cell by cell, purposefully skipping the first row of the sheet. The .Text property of some of the cells returned empty space before the value or between the $ and value, so it had to be removed. Trim removes leading and ending spaces while Replace replaces all spaces in the export.