I have a text file that is not in a format that I can use for printing labels. The current format is like this:
DY234-02 0.5 0.5 Qty 6
U21 U12 U14 U28
TR459-09 0.5 0.5 Qty 9
U11 U78 U7 U8 U30 U24
I need the file to end up like this:
DY234-02 0.5 0.5 Qty 6 U21 U12 U14 U28
TR459-09 0.5 0.5 Qty 9 U11 U78 U7 U8 U30 U24
The files contain about 100 lines of this format I have used vbscript to try to get what I need but the format is not much different. If someone could get me pointed in the right direction that would be great. I am open to all other methods for accomplishing this. Thanks
This is my code in vbscript, but is not doing the job correctly:
Const ForReading = 1
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("C:\Scripts\parse.txt", ForReading)
Do Until objFile.AtEndOfStream
strLine1 = objFile.ReadLine
strLine2 = ""
If Not objFile.AtEndOfStream Then
strLine2 = objFile.ReadLine
End If
strNewLine = strLine1 & strLine2
strNewContents = strNewContents & strNewLine & vbCrLf
Loop
objFile.Close
Set objFile = objFSO.OpenTextFile("C:\Scripts\B3.txt", ForWriting, True)
objFile.Write strNewContents
objFile.Close
If the format is repeated like this, you can read in the text file line by line, and check if there is data on each line. If so join the data to an output string, otherwise add a carriage return to the output string, before finally outputting it to a new text file. Something like this perhaps:
Dim strInFile As String
Dim strOutFile As String
Dim intInFile As Integer
Dim intOutFile As Integer
Dim strInput As String
Dim strOutput As String
strInFile = "J:\downloads\data-in.txt"
strOutFile = "J:\downloads\data-out.txt"
intInFile = FreeFile
Open strInFile For Input As intInFile
intOutFile = FreeFile
Open strOutFile For Output As intOutFile
Do
Line Input #intInFile, strInput
If Len(Trim(strInput)) > 0 Then
strOutput = strOutput & " " & strInput
Else
strOutput = strOutput & vbCrLf
End If
Loop Until EOF(intInFile)
Print #intOutFile, strOutput
Reset
Regards,
Try next code, please. It is fast due to the fact it reads all the text value at once and drop the result, also at once. Everything is happening in memory.
Sub testSplitTextFile()
Dim objFSO As Object, objTF As Object, strIn As String, fullFilename As String, retFile As String
Dim arrIn As Variant, strRet As String, i As Long
'use here your path
fullFilename = "C:\Teste VBA Excel\Teste StackOverflow\TestSplit.txt"
retFile = "C:\Teste VBA Excel\Teste StackOverflow\RetFile.txt"'your path
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTF = objFSO.OpenTextFile(fullFilename, 1)
strIn = objTF.ReadAll 'it reads all the txt file string
objTF.Close
arrIn = Split(strIn, vbCrLf) 'it splits the above string on lines
'Then, it builds a string based on your conditions:
For i = 0 To UBound(arrIn) - 1
If arrIn(i) <> "" And arrIn(i + 1) <> "" Then
strRet = strRet & arrIn(i) & " " & arrIn(i + 1) & vbCrLf
End If
Next i
strRet = left(strRet, Len(strRet) - 1)' it eliminates the last vbCrLf character
FreeFile 1
Open retFile For Output As #1
Print #1, strRet 'it drops, at once the created string
Close #1
End Sub
Related
I used below code from your site to replace strings in a text file and it works fine. But, I don't want specify a file name, it should ready any file like (*.txt or *.xml).
Sub ReplaceStringInFile()
Dim sBuf As String
Dim sTemp As String
Dim iFileNum As Integer
Dim sFileName As String
' Edit as needed
sFileName = "C:\Temp\test.txt"
iFileNum = FreeFile
Open sFileName For Input As iFileNum
Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close iFileNum
sTemp = Replace(sTemp, "THIS", "THAT")
iFileNum = FreeFile
Open sFileName For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
End Sub
Sub ReplaceStringInFile()
Dim sBuf As String
Dim sTemp As String
Dim sFileName As String
Dim FileExt(2) As String
ruta = Application.ActiveWorkbook.Path
ChDrive ruta
ChDir ruta
FileExt(1) = "txt"
FileExt(2) = "xml"
For i = 1 To 2
sFileName = Dir("*." & FileExt(i))
Do
If sFileName = "" Then Exit Do
sTemp = ""
Open sFileName For Input As #1
Do Until EOF(1)
Line Input #1, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close #1
sTemp = Replace(sTemp, "THIS", "THAT")
Open sFileName For Output As #1
Print #1, sTemp
Close #1
sFileName = Dir()
Loop
Next i
End Sub
You can iterate through items in an array!!
Sub FindAndReplaceText()
Dim FileName As String
Dim FolderPath As String
Dim FSO As Object
Dim I As Integer
Dim SearchForWords As Variant
Dim SubstituteWords As Variant
Dim Text As String
Dim TextFile As Object
'Change these arrays to word you want to find and replace
SearchForWords = Array("string1", "string2", "string3")
SubstituteWords = Array("string100", "string200", "string300")
'Change the folder path to where your text files are.
FolderPath = "C:\your_path_here\"
Set FSO = CreateObject("Scripting.FileSystemObject")
FolderPath = IIf(Right(FolderPath, 1) <> "\", FolderPath & "\", FolderPath)
FileName = Dir(FolderPath & "\*.txt")
Do While FileName <> ""
FileSpec = FolderPath & FileName
'Read all the file's text into a string variable.
Set TextFile = FSO.OpenTextFile(FileSpec, 1, False)
Text = TextFile.ReadAll
TextFile.Close
'Scan the string for words to replace and write the string back to the file.
Set TextFile = FSO.OpenTextFile(FileSpec, 2, False)
For I = 0 To UBound(SearchForWords)
Debug.Print Text
Replace Text, SearchForWords(I), SubstituteWords(I)
Debug.Print Text
Next I
TextFile.Write Text
TextFile.Close
FileName = Dir()
Loop
End Sub
Filename = Dir(Filepath & "\" & "*.csv")
While Filename <> ""
SourceFile = Filepath & "\" & Filename
TargetFile = SavePath & "\" & Replace(Filename, ".csv", ".txt")
OpenAsUnicode = False
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
'Detect Unicode Files
Dim Stream: Set Stream = objFSO.OpenTextFile(SourceFile, 1, False)
intChar1 = Asc(Stream.Read(1))
intChar2 = Asc(Stream.Read(1))
Stream.Close
If intChar1 = 255 And intChar2 = 254 Then
OpenAsUnicode = True
End If
'Get script content
Set Stream = objFSO.OpenTextFile(SourceFile, 1, 0, OpenAsUnicode)
arrData = Stream.ReadAll()
Stream.Close
'Create output file
Dim objOut: Set objOut = objFSO.CreateTextFile(TargetFile)
objOut.Write Replace(Replace(arrData,",", "#|#"), Chr(34), "") '-- This line is working fine but it is replacing all the commas inside the text qualifier as well..
objOut.Close
Filename = Dir
Wend
In the above code the line objOut.Write Replace(Replace(arrData,",", "#|#"), Chr(34), "") is replacing all the commas with #|# including the commas inside string.so I want to replace only commas which are not in double quotes.
File containing the string
"A","B,C",D
Result I need is
A#|#B,C#|#D
Thanks for your help in advance.
How about something along the line of:
objOut.Write Mid(Replace(Replace(arrData,""",""", "#|#"), Chr(34), ""), 2)
Basically, this exchanges now "," for #|#. But that's not enough as the file begins with a ". So, this one is being eliminated using the Mid() function. If the file also ends with a " then you would have to adjust that as well.
Based on the speed concerns noted in the comments here is the complete code which I used to test this solution:
Option Explicit
Option Compare Text
Public Sub ConvertFile()
Dim lngRowNumber As Long
Dim strLineFromFile As String
Dim strSourceFile As String
Dim strDestinationFile As String
strSourceFile = "C:\tmp\Extract.txt"
strDestinationFile = "C:\tmp\Extract_b.txt"
Open strSourceFile For Input As #1
Open strDestinationFile For Output As #2
lngRowNumber = 0
Do Until EOF(1)
Line Input #1, strLineFromFile
strLineFromFile = Mid(Replace(strLineFromFile, """,""", "#|#"), 2)
Write #2, strLineFromFile
strLineFromFile = vbNullString
Loop
Close #1
Close #2
End Sub
The tested file was 350 MB with a bit over 4 million rows. The code completed in less than a minute.
Is there a way to find the number of items in an array?
My list of txt files is:
C.txt
D.txt
G.txt
H.txt
With the code below I aggregated the txt files for have output only one txt file (output.txt).
But I need aggregate the files txt only when all four txt files are presents in the path of server else I need alert message in the code.
Can you help me?
Thank you in advance.
Option Compare Database
Dim path
Function go()
Dim ArrTest() As Variant
Dim I As Integer
Dim StrFileName As String
path = CurrentProject.Path
Ouput:
ArrTest = Array("C", "D", "G", "H")
file_global = "" & path & "\Output.txt"
fn = FreeFile
Open file_global For Output As fn
Close
For I = 0 To UBound(ArrTest)
StrFileName = "" & path & "\Output_" & ArrTest(I) & ".txt"
fn = FreeFile
Open StrFileName For Input As fn
Open file_global For Append As fn + 1
Line Input #fn, datum
Do While Not EOF(fn)
Line Input #fn, datum
datums = Split(datum, Chr(9))
For d = 0 To UBound(datums)
If d = 0 Then
datum = Trim(datums(d))
Else
datum = datum & ";" & Trim(datums(d))
End If
Next
Print #fn + 1, datum
Loop
Close
Next I
Application.Quit
End Function
Try this (different than your method, but tried and tested, Assuming All text files including calling workbook reside in same folder) :
Option Explicit
Private Sub AppendTxtfilesConditional()
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim path As String, xp, J As Integer, I As Integer, K As Integer
Dim FSOStream As Object, FSOStream1 As Object, FSO As Object, fol As Object, fil As Object
Dim srcFile As Object, desFile As Object
Dim ArrTest() As Variant
ArrTest = Array("C", "D", "G", "H")
J = 0
path = ThisWorkbook.path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fol = FSO.GetFolder(path)
For I = 0 To UBound(ArrTest)
K = 0
For Each fil In fol.Files
If ArrTest(I) & ".txt" = fil.Name Then
MsgBox (ArrTest(I) & ".txt" & " is found")
J = J + 1
If J > UBound(ArrTest) Then GoTo L12
K = J
End If
Next
If K = 0 Then MsgBox ArrTest(I) & ".txt" & " not found"
Next
MsgBox "aborted"
GoTo final
L12:
For I = 0 To UBound(ArrTest)
Set srcFile = FSO.GetFile(path & "\" & ArrTest(I) & ".txt")
On Error GoTo erLabel
Set desFile = FSO.GetFile(path & "\Output.txt")
On Error GoTo 0
Set FSOStream = srcFile.OpenAsTextStream(iomode:=ForReading, Format:=TristateUseDefault)
Set FSOStream1 = desFile.OpenAsTextStream(iomode:=ForAppending, Format:=TristateUseDefault)
Do While Not FSOStream.AtEndOfStream
xp = FSOStream.ReadLine
FSOStream1.Write vbCrLf & xp ' vbCrLf & xp or 'xp & vbCrLf
Loop
FSOStream.Close
FSOStream1.Close
Next
erLabel:
If Err.Number = 53 Then
MsgBox "Aborted : destination file not found"
GoTo final
End If
final:
Set FSOStream = Nothing: Set FSOStream1 = Nothing: Set FSO = Nothing: Set fol = Nothing
Set fil = Nothing: Set srcFile = Nothing: Set desFile = Nothing
End Sub
N.B If works for you then mark as answer else comment end if
I have the following VBA code:
Sub read_in_data_from_txt_file()
Dim dataArray() As String
Dim i As Integer
Const strFileName As String = "Z:\sample_text.txt"
Open strFileName For Input As #1
' -------- read from txt file to dataArrayay -------- '
i = 0
Do Until EOF(1)
ReDim Preserve dataArray(i)
Line Input #1, dataArray(i)
i = i + 1
Loop
Close #1
Debug.Print UBound(dataArray())
End Sub
I'm trying to read in text line by line (assume 'sample.txt' is a regular ascii file) from a file and assign this data to consecutive elements in an array.
When I run this, I get all my data in the first value of the array.
For example, if 'sample.txt' is:
foo
bar
...
dog
cat
I want each one of these words in a consecutive array element.
What you have is fine; if everything ends up in dataArray(0) then the lines in the file are not using a CrLf delimiter so line input is grabbing everything.
Instead;
open strFileName for Input as #1
dataArray = split(input$(LOF(1), #1), vbLf)
close #1
Assuming the delimiter is VbLf (what it would be coming from a *nix system)
Here is a clean code on how to use for each loop in VBA
Function TxtParse(ByVal FileName As String) As String
Dim fs, ts As Object
Dim strdic() As String
Dim oitem As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.OpenTextFile(FileName, 1, False, -2)
strdic = Split(ts.ReadAll, vbLf)
For Each oitem In strdic
If InStr(oitem, "YourString") <> 0 Then
Else
If InStr(1, oitem, vbTab) <> 0 Then
Debug.Print "Line number is : "; "'" & Replace(oitem, vbTab, "','") & "'"
Else
Debug.Print "Line number is : "; "'" & Replace(oitem, ",", "','") & "'"
End If
End If
Next
End Function
had some troubles with this code. It actually is intended to allocate values to the dir1array(ctr1) and dir2array(ctr2) by looping thru all the files in the directory/folder; Is there a way to make this array work ?
Option Explicit
'*********************************************************************
'* Verify if files have the same name before proceeding to compare *
'* their length *
'* DYNAMIC ARRAYs *
'*********************************************************************
Sub findMatchFilenames()
'Dim fso As fileSystemObject
Dim objMapinfo
Dim fso As New Scripting.FileSystemObject
Dim dir1 As Folder
Dim dir2 As Folder
Dim file1 As File
Dim file2 As File
Dim dir1array() As String
Dim dir2array() As String
ReDim dir1array(0 To 100) As String
ReDim dir2array(0 To 100) As String
Dim ctr1 As Integer
Dim ctr2 As Integer
Dim lLen1 As Long, lLen2 As Long
Dim myFile As String, text As String, textline As String
Set fso = New FileSystemObject
Set dir1 = fso.GetFolder("c:\Temp\")
Set dir2 = fso.GetFolder("c:\Tempo\")
ctr1 = 0
For Each file1 In dir1.Files
ctr2 = 0
For Each file2 In dir2.Files
dir1array(ctr1) = file1.Name
dir2array(ctr2) = file2.Name
If dir1array(ctr1) = dir2array(ctr2) Then
MsgBox "" & dir1array(ctr1) & "" & dir2array(ctr2)
Debug.Print file1.Name & " matches " & file2.Name
lLen1 = FileLen(file1)
lLen2 = FileLen(file2)
If lLen1 <> lLen2 Then
Exit Sub
Else
MsgBox "The files have the same length"
End If
End If
ctr2 = ctr2 + 1
Next file2
ctr1 = ctr1 + 1
Next file1
Close #1
End Sub
The following is a variation of your code, but does not use arrays.
Option Explicit
Sub findMatchFilenames()
Dim lLen1 As Long
Dim lLen2 As Long
Dim oFSO As New Scripting.FileSystemObject
Dim dir1 As Folder
Dim dir2 As Folder
Dim oFile1 As File
Dim oFile2 As File
Dim strFolder1 As String
Dim strFolder2 As String
Close #1 ' I always close first when testing (in case I don't get to normal close)
Close #2
Open "C:\Temp\" & Format(Now(), "_SAME_yyyy-mm-dd_hh-mm") & ".txt" For Output As #1
Open "C:\Temp\" & Format(Now(), "_Different_yyyy-mm-dd_hh-mm") & ".txt" For Output As #2
Set oFSO = New FileSystemObject
strFolder1 = "c:\Temp\"
strFolder2 = "c:\Tempo\"
Set dir1 = oFSO.GetFolder(strFolder1)
Set dir2 = oFSO.GetFolder(strFolder2)
For Each oFile1 In dir1.Files
If oFSO.FileExists(strFolder2 & oFile1.Name) Then ' If it matches same name
Set oFile2 = oFSO.GetFile(strFolder2 & oFile1.Name)
If oFile1.Size = oFile2.Size Then
Print #1, oFile1.Name & vbTab & "File found in both folders; Size is the same;"
Debug.Print oFile1.Name & vbTab & "File found in both folders; Size is the same;"
Else
Print #1, oFile1.Name & vbTab & "Found in both folders; Size is DIFFERENT; " & oFile1.Size & " vs: " & oFile2.Size
Debug.Print oFile1.Name & vbTab & "Found in both folders; Size is DIFFERENT; " & oFile1.Size & " vs: " & oFile2.Size
End If
Else ' Same file not found.
Debug.Print "File not present in 2nd folder: " & oFile1.Name
Print #1, oFile1.Name & vbTab & "File NOT found in second folder;"
End If
Next oFile1
Set oFile1 = Nothing
Set oFile2 = Nothing
Set oFSO = Nothing
Close #1
Close #2
End Sub