VBA read file from specific string to end of file - excel

I am trying to use Microsoft Scripting Runtime to open a text file, look for a specific string of text, and then copy that line and everything below it until the end of the file and write that to excel. I don't need it formatted by column, just want it to appear as it is in the file.. Below is the code that I'm trying to use but I think I've made a few errors.
Sub readFile()
Dim sFileName As String
sFileName = "C:\Users\Jamie\Desktop\REPORT.txt"
With New Scripting.FileSystemObject
With .OpenTextFile(sFileName, ForWriting)
If Mid(sFileName, 3, 6) = "PALLET" Then
.ReadAll
Do Until .AtEndOfStream
Loop
End If
End With
End With
End Sub
Here is an example of the REPORT.TXT
RANDOM DATA THAT'S NOT NEEDEDRANDOM DATA THAT'S NOT NEEDED
RANDOM DATA THAT'S NOT NEEDED
RANDOM DATA THAT'S NOT NEEDED
RANDOM DATA THAT'S NOT NEEDEDRANDOM DATA THAT'S NOT NEEDEDRANDOM DATA THAT'S NOT NEEDED
RANDOM DATA THAT'S NOT NEEDED
PALLET INFORMATION
=================================
UNDER 5 HRS 5
6 to 10 HRS 20
11 to 15 HRS 45
OVER 20 HRS 12
=================================
Report Generated on 2/12/19 by IBM z/OS JBL.9897992

Here's your code refactored to achieve what you want. It mainly shows how to use the FileSystemObject to read text files. I suspect you'll want to make changes once you get to grips with reading the file data, to make placing the data into the sheet easier.
Version 1 - if file is small enough to read into a single string
Sub readFile()
Dim sFileName As String
Dim FileData As String
Dim PalletData As String
Dim idx As Long
Dim LocationToPlaceData As Range
sFileName = "C:\Data\Temp\Report.txt" '"C:\Users\Jamie\Desktop\REPORT.txt"
With New Scripting.FileSystemObject
With .OpenTextFile(sFileName, ForReading)
FileData = .ReadAll
.Close
End With
End With
idx = InStr(FileData, "PALLET")
If idx > 0 Then
PalletData = Mid$(FileData, idx)
'get location to place data - update to suit your needs
Set LocationToPlaceData = ActiveSheet.Range("A1")
'Place Data in a single cell
LocationToPlaceData = PalletData
End If
End Sub
Version 2 - if file is too big to read into a single string.
Sub readFile2()
Dim sFileName As String
Dim FileLine As String
Dim PalletData As String
Dim idx As Long
Dim LocationToPlaceData As Range
sFileName = "C:\Data\Temp\Report.txt" '"C:\Users\Jamie\Desktop\REPORT.txt"
With New Scripting.FileSystemObject
With .OpenTextFile(sFileName, ForReading)
Do Until .AtEndOfStream
FileLine = .ReadLine
idx = InStr(FileLine, "PALLET")
If idx > 0 Then
PalletData = Mid$(FileLine, idx)
Do Until .AtEndOfStream
PalletData = PalletData & vbCrLf & .ReadLine
Loop
End If
Loop
.Close
End With
End With
'get location to place data - update to suit your needs
Set LocationToPlaceData = ActiveSheet.Range("A1")
'Place Data in a single cell
LocationToPlaceData = PalletData
End Sub

Related

VBA code that reads a txt file, places specified words into columns

I'm trying to write a VBA macro that will read through a text document and place specific words into columns. UPDATE: Here's a sample of the file, apparently it's XML, so at least I learned something new today. So i guess what I need is a program to shed the XML parts, and place just the text into columns.
<Alarm>
<ID>1002</ID>
<Type>Fault</Type>
<Message>Bad Brake</Message>
<Tagname>error.e2</Tagname>
</Alarm>
<Alarm>
<ID>1004</ID>
<Type>Fault</Type>
<Message>No Motion</Message>
<Tagname>error.e4</Tagname>
</Alarm>
<Alarm>
<ID>1005</ID>
<Type>Fault</Type>
<Message>Upper safety door open</Message>
<Tagname>error.e5</Tagname>
</Alarm>
Ultimately, I'm trying to put the 4 digit error codes in column A (i.e. 1002, 1004...), and the error message in column B (i.e. Bad Brake, No motion....). I'll paste what I have so far, I tried coding it for just one pair of data to start. I'm stuck trying to get the error message into column B. The error messages all start in the same position on each line, but I can't figure out how to stop copying the text, since each error message is a different length of characters. Any ideas?
(P.S. - I apologize if the code is terrible, I've been interning as an electrical engineer, so my programming has gotten rather rusty.)
Private Sub CommandButton1_Click()
Dim myFile As String, textLine As String, ID As Integer, error_msg As Integer
myFile = "C:\Users\scholtmn\Documents\Projects\Borg_Warner_txt_file\BW_fault_codes.txt"
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textLine
Text = Text & textLine
Loop
Close #1
ID = InStr(Text, "<ID>")
error_msg = InStr(Text, "<Message>")
Range("A1").Value = Mid(Text, ID + 4, 4)
Range("B1").Value = Mid(Text, error_msg + 9, (InStr(Text, " <") - 31))
End Sub
Please, try the next code:
Sub ExtractErrorsDefinition()
'it needs a reference to 'Microsoft XML, v6.0'
Dim XMLFileName As String, oXMLFile As New MSXML2.DOMDocument60, sh As Worksheet
Dim N As MSXML2.IXMLDOMNode, i As Long, arr
Set sh = ActiveSheet 'use here the necessary sheet
XMLFileName = "the full text file path" '"C:\Utile\Teste Corel\XMLtext.txt"
oXMLFile.Load (XMLFileName)
ReDim arr(1 To oXMLFile.SelectNodes("AlarmDictionary/Alarm").length, 1 To 2): i = 1
For Each N In oXMLFile.SelectNodes("AlarmDictionary/Alarm")
arr(i, 1) = N.SelectSingleNode("ID").Text: arr(i, 1) = N.SelectSingleNode("Message").Text: i = i + 1
Next
sh.Range("A2").Resize(UBound(arr), 2).value = arr
End Sub
It may work using late binding, but it is better to have the intellisense suggestion, especially when not very well skilled in working with XML.
If looks complicated to add such a reference, I can add a piece of code to automatically add it.
Please, run the next code to automatically add the necessary reference. Save your workbook and run the first code after:
Sub addXMLRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\msxml6.dll"
End Sub
It looks like the txt file you are using is actually an xml file. If you changed the format, this piece of code I slightly adjusted from here should work fine.
Sub From_XML_To_XL()
Dim xmlWb As Workbook, xSWb As Workbook, xStrPath$, xfdial As FileDialog, _
xFile$, lr%, first As Boolean, r As Range
first = True
Set xfdial = Application.FileDialog(msoFileDialogFilePicker)
xfdial.AllowMultiSelect = False
xfdial.Title = "Select an XML File"
If xfdial.Show = -1 Then xStrPath = xfdial.SelectedItems(1) & ""
If xStrPath = "" Then Exit Sub
Set xSWb = ThisWorkbook
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row ' last used row, column A
xFile = xStrPath
Set xmlWb = Workbooks.OpenXML(xFile)
If first Then
Set r = xmlWb.Sheets(1).UsedRange ' with header
Else
xmlWb.Sheets(1).Activate
Set r = ActiveSheet.UsedRange
Set r = Range(Cells(3, 1), Cells(r.Rows.Count, r.Columns.Count))
End If
r.Copy xSWb.ActiveSheet.Cells(lr + 1, 1)
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row
xmlWb.Close False
first = False
End Sub
I think you'll find this task a lot easier if you take advantage of the fact it is in XML format. You can find more information about working with XML in VBA here.
As Ben Mega already stated: you have an XML-File - why not use XML-functionality.
Add "Microsoft XML, v6.0" to your project references - then you can use this code
Public Sub insertTextFromXML()
Dim objXML As MSXML2.DOMDocument60
Set objXML = New MSXML2.DOMDocument60
If Not objXML.Load("T:\Stackoverflow\Test.xml") Then
Err.Raise objXML.parseError.ErrorCode, , objXML.parseError.reason
End If
Dim nAlarm As MSXML2.IXMLDOMNode
'loop through all alarms and output ID plus message
For Each nAlarm In objXML.SelectNodes("AlarmDictionary/Alarm")
With nAlarm
Debug.Print .SelectSingleNode("ID").Text, .SelectSingleNode("Message").Text
End With
Next
'Filter for ID 1004
Set nAlarm = objXML.SelectSingleNode("AlarmDictionary/Alarm[ID=1004]")
Debug.Print nAlarm.XML
End Sub
You can google for VBA XPath to find out how to access the various values.

Using an array to transfer file names into workbook with multiple sheets

Public Sub GetSOPFiles()
' Set folder path
Const FolderPath As String = "C:\Users\test\Desktop\SOP Audit Excel Prototype"
Const FileExt As String = "docx"
Dim Result As Variant
Dim i As Integer
Dim MyFile As Object
Dim MyFSO As Object
Dim MyFolder As Object
Dim MyFiles As Object
Dim dept As Variant
Dim deptCodes() As Variant
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFSO.GetFolder(FolderPath)
Set MyFiles = MyFolder.Files
' Research built-in Result function in VBA
ReDim Result(1 To MyFiles.Count)
Dim vData As Variant
Dim sTemp As Variant
' Use a For loop to loop through the total number of sheets
For i = 1 To 12
' Setup Select to determine dept values
Select Case i
Case 1
deptCodes = Array("PNT", "VLG", "SAW")
Case 2
deptCodes = Array("CRT", "AST", "SHP", "SAW")
Case 3
deptCodes = Array("CRT", "STW", "CHL", "ALG", "ALW", "ALF", "RTE", "AFB", "SAW")
Case 4
deptCodes = Array("SCR", "THR", "WSH", "GLW", "PTR", "SAW")
Case 5
deptCodes = Array("PLB", "SAW")
Case 6
deptCodes = Array("DES")
Case 7
deptCodes = Array("AMS")
Case 8
deptCodes = Array("EST")
Case 9
deptCodes = Array("PCT")
Case 10
deptCodes = Array("PUR", "INV")
Case 11
deptCodes = Array("SAF")
Case 12
deptCodes = Array("GEN")
End Select
' Loop through files in directory
j = 0
For Each MyFile In MyFiles
' Limit files by file extension
If InStr(1, MyFile.Name, FileExt) <> 0 Then
' Explode file name into array and only pull files with defined dept codes
Dim toSplitFileName As Variant
toSplitFileName = Split(MyFile.Name, "-")
For Each dept In deptCodes
If dept = toSplitFileName(3) Then
ReDim Preserve Result(0 To j)
Result(j) = MyFile.Name
j = j + 1
End If
Next dept
End If
Next MyFile
' Send array to worksheet
Range("A1:A20").Value = Application.WorksheetFunction.Transpose(Result)
Next
End Sub
Okay, you were right about the out of range part. I edited my code and posted it.
What I am trying to do here is pull file names, sort them after parsing their file name (using SELECT to define the different values I am looking for), then transfer those filenames as an array over to each relevant sheet in the workbook.
I had a working (somewhat) function and it was really slow so after receiving some advice on here to send the results to an array then use VBA to transfer directly to worksheets; this is what I have so far.
I'm trying to figure out how I could send the data to each sheet now...I have it working in one sheet. Say it loops through and finds all the files for SELECT Case 1, it sends all of those filenames to column A in Sheet 1. Same for Case 2, etc.
At the moment, it's just populating all of the cells in the defined range with one file name over and over again.
Like so...
Thank you to all of Stack Overflow! After 3 book purchases and a few posts on here so far, I feel I'm starting to make some headway into VBA. Still have a lot to learn though.

Custom file import into excel

I have a flat file with an unusual layout, where the data is stacked vertically. Each block of data begins with the same literal string, but the preceding lines of data vary between each array. The goal is to flatten out the result to single records. I am lost on how to accomplish this. Please help.
Example data from file:
Desired final layout in excel:
The regular expression of which i want to break each record out into its own row is PL_ID%. I just don't know enough about vba scripting to do it. Can someone point me in a direction?
Try this:
Sub flatToExcel()
Dim fileToOpen As String
Dim allData As String, parseData() As String
Dim currentRow As Integer
fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If fileToOpen <> "" Then
Open fileToOpen For Binary As #1
allData = Space$(LOF(1))
Get #1, , allData
Close #1
End If
parseData() = Split(allData, vbCrLf)
currentRow = 0
For i = 0 To UBound(parseData(), 1) - LBound(parseData(), 1)
If Not parseData(i) Like "PL_ID*" Then
ThisWorkbook.Sheets(1).Cells(currentRow, Columns.Count).End(xlToLeft).Offset(0, 1).Value = parseData(i)
Else
currentRow = currentRow + 1
ThisWorkbook.Sheets(1).Cells(currentRow, 1).Value = parseData(i)
End If
Next i
End Sub

Replace text in a cell

I have a sheet that has names, SSNs and 4 columns filled with the following values: S, MB, B.
For said columns I wish to replace S with the number 4, MB with the number 3 and B with the number 2.
Sub replace()
Dim str1, str2, str3, filename, pathname As String
Dim i As Integer
str1 = "MB"
str2 = "B"
str3 = "S"
filename = "p"
pathname = ActiveWorkbook.Path
i = 1
Do While filename <> ""
Set wb = Workbooks.Open(pathname & filename + i)
DoWork wb
wb.Close SaveChanges:=True
filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
End With
End Sub
In the function DoWork, how do I create a loop to replace each of the values?
I mostly agree with Michael--to learn the most, you should get started on your own, and come back with more specific questions. However, I am looking to reach 50 rep so I will pander to you. But do please try to go through the code and understand it.
Your name suggests you are a programmer, so the concepts we make use of should be familiar. I like to work from the inside out, so here goes:
here are my variables:
Dim sFileName As String
Dim sFilePath As String
Dim wbBook As Excel.Workbook
Dim i As Double
Dim wsSheet As Excel.Worksheet
Dim rRange As Range
Dim c As Range
Dim dReplace As Double
At the core, you'll want a select case statement to read each cell and decide what the new value should be. Then you will assign the new value to the cell:
Select Case c.value 'c being the cell we are currently examining
Case "S"
dReplace = 4
Case "M"
dReplace = 3
Case "B"
dReplace = 2
Case Else
'Assuming you should only encounter the above values,
'then anything else is an error
'.assert false will stop the code, or you can replace
'with more refined error handling
Debug.Assert False
End Select
c.value = dReplace
Around that you'll want a for each loop to define the current cell and iterate through all the cells in the range you specify for that particular worksheet:
set rRange = wsSheet.Range("C2:E5000") 'Customize to your range
for each c in rRange.Cells
'...
next
Next level up is the for next loop to iterate through all the worksheets in the current file:
For i = 1 To 30
If wbBook.Sheets(i).Name = "" Then
GoTo NextOne
End If
Set wsSheet = wbBook.Sheets(i)
'...
NextOne:
Next i
The if then statement at the top prevents an error if there are fewer than 30 worksheets in a workbook. If the number of sheets per file varies then this will be useful, if the number is fixed, just adjust the loop to stop and the right spot. Of course, this assumes your workbooks have information on multiple sheets. If not skip the loop altogether.
I'm sure many will criticize my use of goto, but since VBA loops lack a continue command, this is the workaround I employ.
Around that you'll want another iterator to loop through your multiple files. Assuming they are all in the same folder, you can use the Dir() function to grab the file names one-by-one. You give it the file path and (optionally) the file type, and it will return the first file name it finds that meets your cirteria. Run it again and it returns the second file name, etc. Assign that to a string variable, then use the file path plus the file name to open the workbook. Use a do loop to keep going until runs out of files:
sFilePath = "C:\Your File Path Here\"
sFileName = Dir(sFilePath & "*.xlsx")
Do Until sFileName = ""
Set wbBook = Workbooks.Open(sFilePath & sFileName)
'...
wbBook.Save
wbBook.Close
sFileName = Dir()
Loop
Now Put it all together:
Sub ReplaceLetterCodewithNumberCode()
Dim sFileName As String
Dim sFilePath As String
Dim wbBook As Excel.Workbook
Dim i As Double
Dim wsSheet As Excel.Worksheet
Dim rRange As Range
Dim c As Range
Dim dReplace As Double
Application.ScreenUpdating = False
sFilePath = "C:\Your File Path Here\"
sFileName = Dir(sFilePath & "*.xlsx")
Do Until sFileName = ""
Set wbBook = Workbooks.Open(sFilePath & sFileName)
For i = 1 To 30
If wbBook.Sheets(i).Name = "" Then
GoTo NextOne
End If
Set wsSheet = wbBook.Sheets(i)
Set rRange = wsSheet.Cells("C2:E5000") 'Customize to your range. Assumes the range will be the same
For Each c In rRange.Cells
Select Case c.value 'c being the cell we are currently examining
Case "S"
dReplace = 4
Case "M"
dReplace = 3
Case "B"
dReplace = 2
Case Else
'Assuming you should only encounter the above values,
'then anything else is an error
'.assert false will stop the code, or you can replace
'with more refined error handling
Debug.Assert False
End Select
c.value = dReplace
Next
NextOne:
Next i
wbBook.Save
wbBook.Close
sFileName = Dir()
Loop
'Clean up
Set wbBook = Nothing
Set wsSheet = Nothing
Set rRange = Nothing
Set c = Nothing
Application.ScreenUpdating = True
End Sub
I'll provide a high level explanation of this; implementation will be up to you. You'll start with a crawler to open all of these files one by one (a google search should help you with this).
I'm not exactly sure how your sheets are organized but the general idea is to open each sheet and perform the action, so you'll need a list of filenames/paths or do it sequentially. Then once inside the file assuming the structure is the same of each you'll grab the column and input the appropriate value then save and close the file.
If you're looking for how to open the VBA editor go to options and enable the Developer tab.
This is a good beginner project and while you may struggle you'll learn a lot in the process.

trying to store text file rows in VBA

Greetings, I'm hoping for help in figuring out how to store each row of a text file read into a VBA program as a string. I want to modify one of the strings and then put them all back together, but do not know how to read through a text file and store each row as a separate variable in an intelligent way. Thanks for any help you can provide!
If you don't want to add references, you could just go with straight vba code.
Take for instance the following file wordlist.txt:
realize
empty
theorize
line
socialize
here
analyze
The following code uses two methods to do as you described (one more common than the other):
Option Explicit
Sub main()
Dim sFileName As String
Dim sMergedLineArray() As String
Dim sTextToFind As String
Dim sReplacementText As String
Dim sOutputFile As String
Const MY_DELIMITER = "|"
sFileName = "C:\deleteme\wordlist.txt"
sMergedLineArray = ReadFileIntoArray(sFileName)
sTextToFind = "ze"
sReplacementText = "se"
'Loop through each value in the array and make a change if you need to
Dim x As Integer
For x = 0 To UBound(sMergedLineArray)
If InStr(1, sMergedLineArray(x), sTextToFind, vbTextCompare) > 0 Then
sMergedLineArray(x) = Replace(sMergedLineArray(x), sTextToFind, sReplacementText, 1, -1, vbTextCompare)
End If
Next x
sOutputFile = "C:\deleteme\UK_Version.txt"
If Not SpitFileOut(sOutputFile, sMergedLineArray) Then
MsgBox "It didn't work :("
End If
'OR...put it all together, make a mass change and split it back out (this seems unlikely, but throwing it in there anyway)
sTextToFind = "se"
sReplacementText = "ze"
Dim sBigString As String
Dim sNewArray As Variant
sBigString = Join(sMergedLineArray, MY_DELIMITER)
sBigString = Replace(sBigString, sTextToFind, sReplacementText, 1, -1, vbTextCompare)
sNewArray = Split(sBigString, MY_DELIMITER, -1, vbTextCompare)
sOutputFile = "C:\deleteme\American_Version.txt"
If Not SpitFileOut(sOutputFile, sNewArray) Then
MsgBox "It didn't work"
End If
MsgBox "Finished!"
End Sub
Function ReadFileIntoArray(sFileName As String) As String()
Dim sText As String
Dim sLocalArray() As String
Dim iFileNum As Integer
Dim iLineCount As Integer
iFileNum = FreeFile
Open sFileName For Input As #iFileNum
Do Until EOF(iFileNum)
Input #iFileNum, sText
ReDim Preserve sLocalArray(iLineCount)
sLocalArray(iLineCount) = sText
iLineCount = iLineCount + 1
Loop
Close #iFileNum
ReadFileIntoArray = sLocalArray
End Function
Function SpitFileOut(sFileName As String, sMyArray As Variant) As Boolean
Dim iFileNum As Integer
Dim iCounter As Integer
SpitFileOut = False
iFileNum = FreeFile
Open sFileName For Output As #iFileNum
For iCounter = 0 To UBound(sMyArray)
Print #iFileNum, sMyArray(iCounter)
Next
Close #iFileNum
SpitFileOut = True
End Function
If you run the main sub, you'll end up with two files:
UK_Version.txt: This is the result of the first method
American_Version.txt: This is the result of the second
There's lesson 1 of VBA, young Padawan; absorb it, learn and change your login name :P
Look into the FileSystemObject (ref: 1, 2, 3)
You have to go to <Tools/References> menu and include the Microsoft Scripting Runtime and create a global variable Global fso as New FileSystemObject. Now anywhere in your code do things like fso.OpenTextFile() which returns a TextStream. Each TextStream has methods loke ReadLine(), ReadAll(), SkipLine(), WriteLine(), etc ...
Here is a quick sample code.
Global fso as New FileSystemObject
Sub TEST()
Dim ts As TextStream
Set ts = fso.OpenTextFile("text_file.txt", ForReading, False)
Dim s As String
s = ts.ReadAll()
End Sub

Resources