I am working on a tablesheet, using VBA for a unique macro function.
This macro functions allows me to export the values from selected cells in the tablesheet to any folder in my computer.
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer
myFile = "C:\Users\caique.fernandes\Desktop\" & "\NumeroChamados.txt"
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).Value2
If j = rng.Columns.Count Then
Write #1, cellValue
Else
Write #1, cellValue,
End If
Next j
Next i
Close #1
End Sub
There's a column that the values are like 000001, 000002, etc. When I select it to export the values on a .txt file, it exports the values like "000001" but I need only the numbers. I have already tried put single quotes at the beginning of the cell, change the code for Print intead of Write and also changed the cell type for text/number/general, but it continues to exporting the value with quotation marks.
Does anyone know how to solve this?
Ps. All others columns that I have with numbers are prices and dates, and the format for this one have to be like 000001.
If you need more control over how certain columns are output then you can do something like this:
Sub Tester()
Dim myFile As String, rng As Range, i As Long, j As Long
Dim qt As String, lf As String, sep As String, ln As String
myFile = "C:\Tester\NumeroChamados.txt"
Set rng = Selection
Open myFile For Output As #1
For i = 1 To rng.Rows.Count
ln = ""
sep = ""
For j = 1 To rng.Columns.Count
qt = IIf(j = 1 And i > 1, """", "") 'adding quotes? e.g. Col1 only
lf = IIf(j = rng.Columns.Count, vbCrLf, "") 'end of line?
ln = ln & sep & qt & rng.Cells(i, j).Value2 & qt & lf
sep = vbTab 'add separator after first value is written
Next j
Print #1, ln
Next i
Close #1
End Sub
If you need cross-platform support then check out: vbNewline vs Chr(10) as linebreak delimiter in Windows vs. Mac OSX
Related
VBA newbie here.
I have a VBA macro which is designed to create a data table on a named range, paste the data table as values and then export the data table to a .txt file. The problem I have is that each time I run the macro it takes significantly longer to run than the previous time. If I restart Excel, however, the run time "resets" and becomes low again. Once or twice I have even received an error message that Excel has run out of resources. Any help would be greatly appreciated!
Here is the macro:
Sub PR_Calculate()
'
' Total Macro
'
Application.ScreenUpdating = False
Range("Output").Clear
Range("CurrentOutput").Table ColumnInput:=Range("CurrentOutput").Cells(1, 1) 'apply data table to required range
Range("Output").Font.Size = 8
Range("Output").Font.Name = "Segoe UI"
Application.Calculation = xlCalculationAutomatic
Application.Calculation = xlCalculationSemiautomatic
Range("Output").Copy
Range("Output").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Dim outputPath1 As String
Dim outputPath2 As String
outputPath1 = ActiveWorkbook.Worksheets("Run Setup").Range("OutputPath") & Range("CurrentRunParameters").Cells(2, 1).Value & "." & Range("CurrentRunParameters").Cells(2, 2).Value & ".txt"
outputPath2 = ActiveWorkbook.Worksheets("Run Setup").Range("OutputPath") & Range("CurrentRunParameters").Cells(2, 1).Value & "." & Range("CurrentRunParameters").Cells(2, 2).Value & ".Headings.txt"
Call ExportRange(ActiveWorkbook.Worksheets("Policy Results").Range("FileSaveRange"), outputPath1, ",") 'call function to export results to .txt file
Call ExportRange(ActiveWorkbook.Worksheets("Policy Results").Range("HeadingSaveRange"), outputPath2, ",") 'call function to export results to .txt file
End Sub
Function ExportRange(WhatRange As Range, _
Where As String, Delimiter As String) As String
Dim HoldRow As Long 'test for new row variable
HoldRow = WhatRange.Row
Dim c As Range
'loop through range variable
For Each c In WhatRange
If HoldRow <> c.Row Then
'add linebreak and remove extra delimeter
ExportRange = Left(ExportRange, Len(ExportRange) - 1) _
& vbCrLf & c.Text & Delimiter
HoldRow = c.Row
Else
ExportRange = ExportRange & c.Text & Delimiter
End If
Next c
'Trim extra delimiter
ExportRange = Left(ExportRange, Len(ExportRange) - 1)
'Kill the file if it already exists
If Len(Dir(Where)) > 0 Then
Kill Where
End If
Open Where For Append As #1 'write the new file
Print #1, ExportRange
Close #1
End Function
I've tried removing sections of the code piece by piece but it always seems to slow down after consecutive runs.
So, you have a function ExportRange as a string but call it as a subroutine while using the function ExportRange variable in the function...whose value seems to/could get larger and larger each time it's run. I would try not using the function as a local variable for itself, use a Dim String instead. If you need a global variable for it, then declare it outside the function.
Something like this:
Dim MyExportRange As String
Sub ExportRange(WhatRange As Range, _
Where As String, Delimiter As String)
Dim HoldRow As Long 'test for new row variable
HoldRow = WhatRange.Row
Dim c As Range
MyExportRange = ""
'loop through range variable
For Each c In WhatRange
If HoldRow <> c.Row Then
'add linebreak and remove extra delimeter
MyExportRange = Left(MyExportRange, Len(MyExportRange) - 1) _
& vbCrLf & c.Text & Delimiter
HoldRow = c.Row
Else
MyExportRange = MyExportRange & c.Text & Delimiter
End If
Next c
'Trim extra delimiter
MyExportRange = Left(MyExportRange, Len(MyExportRange) - 1)
'Kill the file if it already exists
If Len(Dir(Where)) > 0 Then
Kill Where
End If
Open Where For Append As #1 'write the new file
Print #1, MyExportRange
Close #1
End Sub
Looping cell-by-cell through a range can be slow, so you could try reading the whole range into an array and then writing the file from that:
Sub tester()
ExportRange ActiveSheet.Range("A1").CurrentRegion, "C:\Temp\Test56.txt", "," '
End Sub
Sub ExportRange(WhatRange As Range, Where As String, Delimiter As String)
Dim arr, r As Long, c As Long, sep As String, s As String, ff
If Len(Dir(Where)) > 0 Then Kill Where 'kill file if already exists
ff = FreeFile
Open Where For Output As #ff 'not appending...
If WhatRange.Cells.Count > 1 Then
arr = WhatRange.Value
For r = 1 To UBound(arr, 1)
s = ""
sep = ""
For c = 1 To UBound(arr, 2)
s = s & sep & arr(r, c)
sep = Delimiter
Next c
Print #ff, s
Next r
Else
Print #ff, WhatRange.Value 'only one cell
End If
Close #ff
End Sub
I'm trying to export Excel data to individual text files. Currently, the code I've got below exports the selection in Excel to a file titled "AgreementText.txt". I'd like to do two things to improve it, but I'm not sure how:
Firstly, I want to title each .txt file something different. The titles of the files are listed in a column 4 spaces to the left of each selection. Is there any way I can grab the title each time from that column?
Secondly, the text currently appears in the text file with quotation marks around it. Is there any way I can remove those?
Edit: Thirdly, I also need to specify a different file path to the default, but I'm not sure how.
Thanks in advance!
Sub TextFileExport()
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer
myFile = Application.DefaultFilePath & "\AgreementText.txt"
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
Write #1, cellValue
Else
Write #1, cellValue,
End If
Next j
Next i
Close #1
End Sub
Firstly, the title can easily just get retrieved by getting the cell value. Assuming it will be in the same row as the top of your selection, but 4 columns to the right, you can do it as follows:
myFile = Application.DefaultFilePath & "\" & Selection.Cells(1, Selection.Columns.Count + 4) & ".txt"
Open myFile For Output As #1
Secondly, you can use Print instead of Write to print without quotes. I find the easiest is to just build the whole line you want to write as one string and then do a single Print command for each line.
Putting it all together:
Sub TextFileExport()
Dim myFile As String
Dim rng As Range
Dim line
Dim i As Integer
Dim j As Integer
Set rng = Selection
myFile = Application.DefaultFilePath & "\" & rng.Cells(1, rng.Columns.Count + 4) & ".txt"
Open myFile For Output As #1
For i = 1 To rng.Rows.Count
line = ""
For j = 1 To rng.Columns.Count
line = line & rng.Cells(i, j).Value
If j < rng.Columns.Count Then
line = line & ","
End If
Next
Print #1, line
Next
Close #1
End Sub
I am able to print the values from excel to notepad, but the format is bit different,
Dim txtFile As String, rng As Range, cellValue As Variant, r As Integer, c As Integer
txtFile = slocation & "\" & "Cont_name_" & Filename & ".txt"
lrow = Range("I" & Rows.Count).End(xlUp).Row
Range("A2:G" & lrow).Select
Set rng = Selection
Open txtFile For Output As #1
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
cellValue = rng.Cells(r, c).Value
If InStr(cellValue, "/") Then
cellValue = Format(cellValue, "yyyyMMDD")
End If
If c = rng.Columns.Count Then
Print #1, cellValue
Else
Print #1, cellValue,
End If
Next c
Next r
Close #1
Spaces are more than the requirement, please help to achieve the desired output,because the tool is accepting only the desired format
Your first output uses the standard "print zones" in every 14th column (positions 1, 15, 29, ...), which you get by printing with appended comma
.............|.............|.............|.............|.............|.............|
XXX-XX-XXXX 20190111 AA 123 NAME NAME XXXXX
Your desired output starts at the next multiple of 8 characters (1, 9, 17, ...)
.......|.......|.......|.......|.......|.......|.......|.......|.......|
XXX-XX-XXXX.....20190111........AA......123.....NAME....NAME....XXXXX
You can set the next print position in your file by Seek
Private Sub SaveAsText()
Dim rng As Range
Dim r As Long, c As Long
Set rng = ActiveSheet.Range("A1:G1")
Dim file1 As Integer
file1 = FreeFile
Open ThisWorkbook.Path & "\test.txt" For Output As file1
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If c = 1 Then
Print #file1, CStr(rng.Cells(r, c).Value);
Else
Seek #file1, (Seek(file1) \ 8 + 1) * 8 + 1
Print #file1, CStr(rng.Cells(r, c).Value);
End If
Next c
Next r
Close #file1
End Sub
Additional Hints:
Use Freefile to get the next free file number (which might be 1).
Use CStr() to prevent the automatically added space characters before and after numeric values.
I have an excel file that looks like this:
3001 T81 90300010 001
3001 T81 90300011 001
and the issue is that some of the numbers are numbers stored as txt.
Also there are strings: "T81"
I need the outputted txt file to look like this:
3001T8190300010001
No Spaces, quotes, etc.
I was able to run this script to do most of the legwork:
Dim myFile As String, rng As Range, cellValue As Variant, I As Integer, j As Integer
myFile = Application.DefaultFilePath & "\test_data_output.txt"
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
Write #1, cellValue
Else
Write #1, cellValue,
End If
Next j
Next I
Close #1
Now its output is not quite perfect:
3001,"T81",90300010,"001"
3001,"T81","90300011","001"
In the line where you set cellValue, just keep adding the strings together (converting value to strings):
cellValue = cellValue + Cstr(rng.Cells(I, j).Value)
Then between your next j and next I, reset cellValue:
Next j
cellValue = ""
Next I
Dim v as Variant
v = rng.Value
For i = LBound(v,1) to UBound(v,1)
Write #1, Replace(Replace(Join(WorksheetFunction.Index(v,i,0),""),",","")," ","")
Next
I have procedure in VBA to write data to text file (.txt), but I need separeted values this char - "|". Can you help me?
Sub Sales_tmr()
Dim myFile As String
Dim rng As Range
Dim cellValue As Variant
Dim i As Integer
Dim j As Integer
myFile = Application.DefaultFilePath & "\sales.txt"
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
Write #1, cellValue
Else
Write #1, cellValue, ' Here I will separeted char "|"
End If
Next j
Next i
Close #1
End Sub
Thanks!
Cant you just add it to the value?
cellValue = rng.Cells(i, j).Value
If j = rng.Columns.Count Then
Write #1, cellValue
Else
cellValue = cellValue & "|"
Write #1, cellValue, ' Here I will separeted char "|"
End If
UPDATED
To make it update each row in one go without quotes and commas. Move your write to after your first loop;
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
cellValue = cellValue & "|"
End If
Next j
Write #1, cellValue,
Next i
This will output
"Joe|Blogs|72",
"Dave|Mitchell|34",
etc
Please see the documentation to the VB Write function: http://msdn.microsoft.com/en-us/library/yxw69s8t%28v=vs.90%29.aspx
Unlike the Print function, the Write function inserts commas between items and quotation marks around strings as they are written to the file.
You will have to use a different function to write your lines to a file, e.g. by using Scripting.FileSystemObject and WriteLine. See http://msdn.microsoft.com/en-us/library/t5399c99%28v=vs.84%29.aspx
Can you try with the following object? Maybe that the Open myFile For Output As #1 has some kind of problem:
Dim SpaceVar as String
Dim Writer As Object
SpaceVar = Chr(124) ' Basically your "|"
Set Writer = CreateObject("ADODB.Stream")
With Writer
.Type = 2 ' Specifies stream type - save text data.
.Charset = "utf-8" ' Specifies charset for the source text data.
.lineseparator = 10 ' Pushes enter when a line is finished
.Open
End With
' Here you use the "Writer" Object as many times you want with the strings you want
Writer.WriteText NameVar & SpaceVar & SurnameVar & SpaceVar & AgeVar
' These variables I didn't declare, but you should in case you wanted to use them to store your strings
With Writer
.SaveToFile FileNameString, 2 ' Saves (and overwrites) data ' be sure to declare the variable, should you use it!
.Close
End With
Set Writer = Nothing