I have an Excel worksheet and I need to copy a range of values into an external .txt file at a given line. (E.g. copy the values of cells A1:A7, and paste them in line 100 of a pre-existing .txt file. I was able to select the range of values, however I can not paste into a specific line. Any ideas?
This is a hack:
Public Const FPath = "C:\Temp\YourFile.txt"
Sub test()
Dim fso As New Scripting.FileSystemObject
Dim txtFile As Scripting.TextStream
Dim val As String
Dim valArr() As Variant, v As Variant
valArr = Sheet1.Range("A1:A7").Value2
Dim count As Long
For count = LBound(valArr) To UBound(valArr)
'choose your delimiter, I used space
val = val & IIf(count = LBound(valArr), "", " ") & valArr(count, 1)
Next count
Set txtFile = fso.OpenTextFile(FPath, ForReading, False)
Dim txtArr() As String
txtArr = Split(txtFile.ReadAll, vbCrLf)
txtFile.Close
If UBound(txtArr) >= 4 Then 'I am using 5 instead of 100 - change as necessary
txtArr(4) = val
're-write file
Set txtFile = fso.OpenTextFile(FPath, ForWriting, False)
txtFile.Write Join(txtArr, vbCrLf)
txtFile.Close
Else
'append to file if it has less then 5 lines
Set txtFile = fso.OpenTextFile(FPath, ForAppending, False)
txtFile.Write val
txtFile.Close
End If
Set txtFile = Nothing
End Sub
Related
I have a VBA code that quickly transfer data from CSV files, but unfortunately exclude leading zeros (For example 000123 is converted to 123)
Filename = "c:\text.csv"
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet
Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Temp")
Filename = "c:\text.csv"
Set wbO = Workbooks.Open(Filename)
wbO.Sheets(1).Cells.Copy wsI.Cells
wbO.Close SaveChanges:=False
I have tried to add the following after opening the csv file > Cells.NumberFormat = "#"
Set wbO = Workbooks.Open(Filename)
Cells.NumberFormat = "#"
wbO.Sheets(1).Cells.Copy wsI.Cells
wbO.Close SaveChanges:=False
Unfortunately, it is not working and the problem I see is that once the file opens already is missing the leading zeros
Is it possible to open the file without affecting the leading zeros and show all the data as text to maintain the leading zeros?
Try this way, please:
Sub testOpenWithLZeroTxt()
Dim Filename As String, wbI As Workbook, wbO As Workbook, wsI As Worksheet
Dim arrTXT, nrCol As Long, arr(), i As Long, sep As String, lineSep As String
Dim allTxt As String, txtStr As Object, fileTxt As String, fs As Object, f As Object, ts As Object
Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Temp")
Filename = "c:\text.csv"
fileTxt = Split(Filename, ".")(0) & ".txt" 'create a helper txt file using the csv string content
Set fs = CreateObject("Scripting.FileSystemObject")
allTxt = fs.OpenTextFile(Filename, 1).ReadAll 'reed the csv file content
fs.CreateTextFile fileTxt
Set f = fs.GetFile(fileTxt)
Set ts = f.OpenAsTextStream(2, -2)
ts.write allTxt 'write the csv content in a newly created txt file
ts.Close
'Check the number of text file columns:_______
sep = vbLf ' if not working you can try vbCrLf. It works so on your file
lineSep = "," 'it my be vbTab, ";" etc. It works so on your file
arrTXT = Split(allTxt, sep)
nrCol = UBound(Split(arrTXT(0), lineSep))
'_____________________________________________
ReDim arr(nrCol) 'redim the format array
For i = 0 To nrCol
arr(i) = Array(i + 1, 2) 'fill the format array with variant for TEXT Format!
Next
'open the helper txt file as you need:
Workbooks.OpenText Filename:=fileTxt, origin:=437, startRow:=1, _
DataType:=xlDelimited, Tab:=False, Comma:=True, FieldInfo:=arr()
Set wbO = ActiveWorkbook
'wbO.Sheets(1).cells.Copy wsI.Range("A1") 'copy the content
wbO.Close SaveChanges:=False 'close the file
Kill fileTxt 'kill helper txt file
End Sub
Edited:
I changed the code philosophy. It will firstly read the csv content in a string variable and create a txt file using the obtained string and open it as text, which certainly should work. It will work for any number of columns in the csv file.
The line break in your csv file is unix LF. This corresponds to chr(10).
Since the number of columns in the first row and the number of columns in the next row are inconsistent, a little bias was used. An array was created by doubling the number of columns in the first row.
Sub test()
Dim Ws As Worksheet
Dim Fn As String
Dim Arr As Variant
Fn = "Example.csv"
'Fn = "c:\text.csv"
Set Ws = Sheets("Temp")
Arr = getDatFromCsv(Fn)
With Ws
.Cells.NumberFormat = "#"
.Cells = Empty
.Range("a1").Resize(UBound(Arr, 1) + 1, UBound(Arr, 2) + 1) = Arr
End With
End Sub
Function getDatFromCsv(strFn As String) As Variant
Dim vR() As String
Dim i As Long, r As Long, j As Integer, c As Integer
Dim objStream As Object
Dim strRead As String
Dim vSplit, vRow
Dim s As String
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Charset = "utf-8"
.Open
.LoadFromFile strFn
strRead = .ReadText
.Close
End With
vSplit = Split(strRead, Chr(10)) 'Unix Lf ~~> chr(10)
r = UBound(vSplit)
c = UBound(Split(vSplit(0), ",", , vbTextCompare))
ReDim vR(0 To r, 0 To c * 2)
For i = 0 To r
vRow = Split(vSplit(i), ",", , vbTextCompare)
'If UBound(vRow) = c Then 'if it is empty line, skip it
For j = 0 To UBound(vRow)
vR(i, j) = vRow(j)
Next j
'End If
Next i
getDatFromCsv = vR
Set objStream = Nothing
End Function
Result Image
Use OpenText method instead.
The most important parameter is FieldInfo. You need to pass:
an array containing parse information for individual columns of data. The interpretation depends on the value of DataType. When the data is delimited, this argument is an array of two-element arrays, with each two-element array specifying the conversion options for a particular column. The first element is the column number (1-based), and the second element is one of the XlColumnDataType constants specifying how the column is parsed.
In other words, every column with leading zeros, has to be defined as xlTextFormat.
I'd suggest to record macro. ;) An option to load text data, you'll find under Data tab -> ... -> From text/CSV
I was wondering if anyone knew a way to parse rather large data files in Excel VBA because whenever I try the simple data parse it crashes the program. The data is formatted as such
593972,Data,15:59:59.820,9519,9519,Px(25.5),9519,9500,10001,10226,10451,0,0,0,0,0,28.7604,25.4800,25.4841
and there are about 3 million lines formatted exactly the same and I want to pull out certain values in the line if the first value (in the case above it is 593972) is a specific number. I am rather new to VBA so any help would be much appreciated. Thanks so much for your time!
Try using FSO; modify to suit your needs.
Sub ParseFile()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strLine As String
Dim arrLine() As String
Dim objFile
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set objFile = fso.OpenTextFile("C:\Temp\Text File.txt", ForReading) '<modify path as needed
Do Until objFile.AtEndOfStream
strLine = Trim(objFile.Readline)
If (strLine <> "") Then
arrLine = Split(strLine, ",") 'one dimensional array
'parse the arrLine to test for the data you need
Dim FirstValue as String
FirstValue = arrLine(0)
If FirstValue = "593972" Then
'put the data in Excel if desired/needed
End If
End If
Loop
objFile.Close
Set objFile = Nothing
End Sub
The Sub below opens a text stream, reads it line by line, and verifies if the first field has a certain value for each line; adapt it to do what you'd want:
Public Sub ReadAndValidate( _
ByVal FileName As String, _
ByVal FieldKey As String _
)
' This function doesn't do error handling, assumes that the '
' field separator is "," and that the key field is first. '
' It uses the "Scripting" lib; "Microsoft Scripting Runtime"'
' needs to be referenced by the containing workbook. '
Dim line As String
Dim keylen As Long
Dim fs As Scripting.FileSystemObject
Dim f As Scripting.TextStream
Let FieldKey = FieldKey & "," ' add the separator to the key '
Let keylen = Strings.Len(FieldKey)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile( _
FileName:=FileName, _
IOMode:=IOMode.ForReading _
)
While Not f.AtEndOfStream
Let line = f.ReadLine()
If Strings.Left$(line, keylen) = FieldKey Then
' replace the statement below with your code '
Debug.Print line
End If
Wend
f.Close
End Sub
Apologies for a noob question but I've been fiddling around with this code:
https://stackoverflow.com/a/7151963/3672159
and can't seem to get it modified to do the following (very slight modifications of the code above):
Take as input a worksheet that is called "Export Data" (rather than "Sheet1" as in the existing code; the space seems to cause problems)
Automatically create an empty file for each cell of column D, which should have as its content the value of the respective D cell (same as with the "Disclaimer" data in the code above)
Name each file based on the values of the corresponding C cells (so for me it's name=column C, content=column D rather than B and A in the original code).
I've modified the code as follows:
Sub ExportFiles()
Dim sExportFolder, sFN
Dim rStoreId As Range
Dim rAbstract As Range
Dim oSh As Worksheet
Dim oFS As Object
Dim oTxt As Object
'sExportFolder = path to the folder you want to export to
'oSh = The sheet where your data is stored
sExportFolder = "my file path\txt"
Set oSh = Export Data
Set oFS = CreateObject("Scripting.Filesystemobject")
For Each rStoreId In oSh.UsedRange.Columns("D").Cells
Set rAbstract = rStoreId.Offset(, -1)
'Add .txt to the article name as a file name
sFN = rStoreId.Value & ".txt"
Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & sFN, 2, True)
oTxt.Write rAbstract.Value
oTxt.Close
Next
End Sub
The only thing this does (as does the original code) is create one empty unnamed txt file.
Any help is greatly appreciated!
Try this...
Sub ExportFiles()
Dim sExportFolder, sFN
Dim rStoreId As Range
Dim rAbstract As Range
Dim oSh As Worksheet
Dim oFS As Object
Dim oTxt As Object
'sExportFolder = path to the folder you want to export to
'oSh = The sheet where your data is stored
sExportFolder = "C:\Users\Rich\Desktop"
Set oSh = ThisWorkbook.Sheets("Export Data")
Set oFS = CreateObject("Scripting.Filesystemobject")
For Each rStoreId In oSh.Columns("D").Cells
If IsEmpty(rStoreId.Value) Then
Exit For
End If
Set rAbstract = rStoreId.Offset(, -1)
'Add .txt to the article name as a file name
sFN = rStoreId.Value & ".txt"
Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & sFN, 2, True)
oTxt.Write rAbstract.Value
oTxt.Close
Next
End Sub
You need to select the sheet correctly with (Assuming it is within the same workbook as the code)...
Set oSh = ThisWorkbook.Sheets("Export Data")
And I changed how you were iterating through the range...
For Each rStoreId In oSh.Columns("D").Cells
If IsEmpty(rStoreId.Value) Then
Exit For
End If
Next
This just goes through column D's cells until it hits an empty one, I couldn't quite get it working using UsedRange and this (more old skool) method works in my tests.
This works for me. It writes each value in cells in column D to a text file that is named based on the entry in column C and puts all text files in user specified folder:
Sub ExportFiles()
Dim exportFolder As String
Dim fso As FileSystemObject
Dim stream As TextStream
Dim cl As Range
exportFolder = "C:\User\ExportFolder" //Add you folder path here
Set fso = New FileSystemObject
For Each cl In Worksheets("Export Data").UsedRange.Columns("D").Cells
Set stream = fso.CreateTextFile(filepath & "\" & cl.Offset(0, -1).Value & ".txt", 2, True)
stream.Write cl.Value
stream.Close
Next
End Sub
I would like to loop through an Excel worksheet and to store the values based on a unique ID in a text file.
I am having trouble with the loop and I have done research on it with no luck and my current nested loop continually overflows. Instead of updating the corresponding cell when the control variable is modified, it continues to store the initial Index value for all 32767 iterations.
Please can someone explain why this is happening, and provide a way of correcting it?.
Sub SortLetr_Code()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Value of cell for example B1 starts out as X
Dim x As Integer
Dim y As Integer
x = 2
y = 2
'Cell References
Dim rwCounter As Range
Dim rwCorresponding As Range
Dim rwIndexValue As Range
Dim rwIndexEnd As Range
Dim rwIndexStore As Range
'Variables for files that will be created
Dim FilePath As String
Dim Filename As String
Dim Filetype As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
Filetype = ".dat"
'Use Cell method for Loop
rwIndex = Cells(x, "B").Value
Set rwCounter = Range("B" & x)
'Use Range method for string manipulation
Set rwCorresponding = Range("A" & x)
Set rwIndexValue = Range("B" & y)
Set rwIndexStore = Range("B" & x)
Set rwIndexEnd = Range("B:B").End(xlUp)
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
For Each rwIndexStore In rwIndexEnd.Cells
'Get Substring of cell value in BX for the file name
Do Until IsEmpty(rwCounter)
Filename = Mid$(rwIndexValue, 7, 5)
Set FileWrite = FileCreate.CreateTextFile(FilePath + Filename + Filetype)
'Create the file
FileWrite.Write (rwCorresponding & vbCrLf)
Do
'Add values to the textfile
x = x + 1
FileWrite.Write (rwCorresponding & vbCrLf)
Loop While rwCounter.Value Like rwIndexValue.Value
'Close this file
FileWrite.Close
y = x
Loop
Next rwIndexStore
End Sub
I don't see a place you are setting rwCounter inside the loop.
It looks like it would stay on range("B2") and x would just continue to increase until it hits an error, either at the limit of integer or long.
add Set rwCounter = Range("B" & x) somewhere inside your loop to increment it
This is the solution.
Sub GURMAIL_File()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Variables that store cell number
Dim Corresponding As Integer
Dim Index As Integer
Dim Counter As Integer
Corresponding = 2
Index = 2
Counter = 2
'Cell References
Dim rwIndexValue As Range
'Variables for files that will be created
Dim l_objFso As Object
Dim FilePath As String
Dim Total As String
Dim Filename As String
Dim Filetype As String
Dim FolderName As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
'Name of the folder to be created
FolderName = Mid$(ActiveWorkbook.Name, 9, 8) & "\"
'Folder path
Total = FilePath & FolderName
'File Extension
Filetype = ".dat"
'Object that creates the folder
Set l_objFso = CreateObject("Scripting.FileSystemObject")
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
'Get Substring of letter code in order to name the file. End this loop once ID field is null.
Do While Len(Range("A" & Corresponding)) > 0
'Create the directory if it does not exist
If Not l_objFso.FolderExists(Total) Then
l_objFso.CreateFolder (Total)
End If
'Refence to cell containing a letter code
Set rwIndexValue = Range("B" & Index)
'Substring of that letter code
Filename = Mid$(rwIndexValue, 7, 5)
'Create the file using the substring and store it in the proper location
Set FileWrite = FileCreate.CreateTextFile(Total + Filename + Filetype, True)
'For each letter code, find the corresponding values. End the loop once the last value for the letter code is stored.
Do While Range("B" & Index) Like Range("B" & Counter)
'Add each line to the text file.
FileWrite.WriteLine (Range("A" & Corresponding))
'Incrementer variables that allow you to exit the loop
'if you have reached the last value of the current letter code.
Corresponding = Corresponding + 1
Counter = Counter + 1
Loop
'Close the file you were writing to
FileWrite.Close
'Make sure that Index value is updated to the next letter code
Index = Counter
'In case Index value needs updating (safeguard to make sure that the new letter code is stored to index value).
Set rwIndexValue = Range("B" & Index)
Loop
End Sub
I'm trying to write a simple script that looks into a folder, finds the specified file, then spits out the timestamp on a cell. That is the easy part which I already have, (using a string & object).
The part where I'm having issues is having this repeat over 400 specific files within a folder of +1,000 files. All the files are labeled differently, but some may have similarities (AB.xls, AC.xls, AD.xls ; A1.xls, A2.xls, etc). I could go the long way and just rinse and repeat just changing the string name to each specific file, but that would take too long to write.
Is there a short cut to loop this or would I need to add a variable line for the file name to change each time?
Here is a snippet:
Sub Timecheck()
Dim oFS As Object
Dim strFilename As String
strFilename = "Where the file is located"
Set oFS = CreateObject("Scripting.FileSystemObject")
Sheets("tab").Activate
ActiveSheet.Cells(3, 3).Value = oFS.GetFile(strFilename).Datelastmodified
Set oFS = Nothing
End Sub
If the names of the files are on another sheet you need to create another function that will iterate through that range of cells.
Once you have that function in place have it call this function:
Sub Timecheck(byval aCell as object,byval X as integer,Y as integer)
Dim oFS As Object
Dim strFilename As String
strFilename = aCell.Text
Set oFS = CreateObject("Scripting.FileSystemObject")
Sheets("tab").Activate
ActiveSheet.Cells(X,Y).Value = oFS.GetFile(strFilename).Datelastmodified
Set oFS = Nothing
End Sub
where X and Y are the coordinates of the cell you want to put the data in. You call it by passing in the cell in the range that you have grabbed from the other sheet.
Alternately if you do not want to have to traverse a range then put each file name in a single cell on the new sheet and delimit it with a character that won't show up in the name. Then take that and break it into the file names.
Good luck.
EDIT:
If you wanted to iterate through the items in a delimited list inside a cell, then once you have the cell text in an object:
http://msdn.microsoft.com/en-us/library/6x627e5f(v=vs.80).aspx
with an input of 'filename1.xls^filename2.xls^filename3.xls'
call once you have the cell object that contains the file list
DoStuff(cellObejct, "^")
Public Sub DoStuff( byval aCell as object, byval specialChar as string)
Dim ListOfNames as Variant
Dim intIndex, xCell, yCell as integer
ListOfNames = Split(aCell.Text,specialChar)
xCell = 1
yCell = 1
For intIndex = LBound(ListOfNames) To UBound(ListOfNames)
TimeCheck(ListOfNames(intIndex),xCell,yCell)
yCell = yCell + 1
Next intIndex
End Sub
Sub Timecheck(byval fName as string,byval X as integer,Y as integer)
Dim oFS As Object
Set oFS = CreateObject("Scripting.FileSystemObject")
Sheets("tab").Activate
ActiveSheet.Cells(X,Y).Value = oFS.GetFile(fName).Datelastmodified
Set oFS = Nothing
End Sub
To loop thought a folder:
Sub timecheck()
Dim FSO As Object
Dim FLD As Object
Dim fil As Object
Dim i As Long
Dim strFolder As String
i = 1
strFolder = "C:\Your Folder Name"
'Create the filesystem object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get a reference to the folder you want to search
Set FLD = FSO.GetFolder(strFolder)
'loop through the folder and get the file names
For Each fil In FLD.Files
Sheets("Sheet1").Cells(i, 1) = fil.Name ' Filename in column A
Sheets("Sheet1").Cells(i, 2) = fil.datelastmodified ' Date in column B
i = i + 1
Next
End Sub