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
Related
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.
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
Originally I have a list of name of text files in the column A (in excel), and I want to go through all files to open and count its rows. When I run the script below the counter result is '1'
When I open the text files with Notepad++ or Sublime Text I see the lines of the file in different rows. But when I open the files with Notepad I see whole text in one row. What is the problem in this case and how can I fix it. (The line divider is 'LF'.)
Sub counting()
Dim FilePath As String
Dim counter As Integer
Dim curLine As String
FilePath = "C:\Users\kornel.fekete\Desktop\test\Test.txt"
Open FilePath For Input As #1
Do While Not EOF(1)
counter = counter + 1
Line Input #1, curLine
Loop
Cells(1, 1).Value = counter
Close #1
End Sub
I have to do this counting with more than 100 text files.
You could use a textstream:
Sub counting()
Dim fso As New FileSystemObject
Dim ts As TextStream
Dim longtext As String
Dim lines As Variant
Set ts = fso.OpenTextFile("C:\Users\kornel.fekete\Desktop\test\Test.txt", ForReading, False)
longtext = ts.ReadAll
ts.Close
lines = Split(longtext, vbLf)
Cells(1, 1) = UBound(lines) - LBound(lines) + 1
End Sub
You need to set a reference to Microsoft Scripting Runtime.
I have a column in a spreadsheet.
The format of the data in each cell is aa-0001-xx.
I need to examine the whole column to find the highest value of the sequence number. this would be the substring from column4 thru column7.
I can find the sequence number using Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4)
But I need to find the max sequence in the whole column.
I am doing this in VBA.
Any help would be appreciated.
Here is my code so far:
Private Sub CommandButton1_Click()
Dim sQuoteNumber As String
Dim sFileName As String
Dim sPathName As String
Dim checkit As String
'Log the Quote
'First, open the log file and determine the next sequential log number.
sPathName = "C:\Users\Rich\Documents\Bryan\BigProject\"
sFileName = "QuoteLog2016.xlsx"
ControlFile = ActiveWorkbook.Name
Workbooks.Open Filename:=sPathName & sFileName
'Create the new Quote Number
checkit = Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) ' This is a temp test line
If Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) = "" Then
sQuoteNumber = "16-0001"
Else
'find the biggest number
'Here I was looking to like pass the mid function to a Max function of some sort.
sQuoteNumber = "16-0002"
End If
MsgBox ("The new Quote Number is: " + sQuoteNumber)
'Save the log entry
Workbooks(sFileName).Close
All of the comments made to your answer would work well for you. It's also true that there's no evidence in your code at having attempted something, however rudimentary, and this is why answers to a rather trivial task are not forthcoming for you. Perhaps, in future, have a go at some kind of solution ( even if it feels more guesswork than anything) and people on this site will be much more supportive of you.
To set you on your way, you could make use of the Split() function which converts a String into a String array, separated by a nominated value - in the case of your quotations, you could use "-" as your separator. This might be easier than your Mid function and will deal with the case of different sized quotations.
The code below will get you started but you'd want some error handling in there to test, for example, that each cell splits appropriately or that any cells aren't blank. I'll leave all of that to you.
Option Explicit
Private mLastQuote As Long
Public Sub Test()
Initialise 'call this routine just once at the start of your project
MsgBox GetNextQuote(16) 'use the GetNextQuote() function to get next number
MsgBox GetNextQuote(16)
MsgBox GetNextQuote(16)
End Sub
Private Function GetNextQuote(prefix As Integer) As String
mLastQuote = mLastQuote + 1
GetNextQuote = CStr(prefix) & "-" & _
Format(mLastQuote, "000#")
End Function
Private Sub Initialise()
Const PATH_NAME As String = "C:\Users\Rich\Documents\Bryan\BigProject\"
Const FILE_NAME As String = "QuoteLog2016.xlsx"
Const QUOTE_COL As String = "B"
Dim wb As Workbook
Dim ws As Worksheet
Dim v As Variant
Dim r As Long
Dim parts() As String
Dim num As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Open(PATH_NAME & FILE_NAME, True, True)
Set ws = wb.Worksheets("Sheet1")
'Read quote values into variant array
With ws
v = .Range(.Cells(2, QUOTE_COL), _
.Cells(.Rows.Count, QUOTE_COL).End(xlUp)) _
.Value2
End With
'Find max quote
For r = 1 To UBound(v, 1)
parts = Split(v(r, 1), "-") 'splits quote into 3 parts
num = CLng(parts(1)) 'index (1) is the middle part
If num > mLastQuote Then mLastQuote = num
Next
wb.Close False
Application.ScreenUpdating = True
End Sub
I am working on an excel spreadsheet that takes data from a CSV file (produced automatically by an external system).
I have used:
Data->Get External Data->From Text
And it works perfect !
However i am not able to format the imported data as a table :-(
It gives the following message :
Your Selection overlaps one or more external data ranges. Do you want to convert the selection to a table and remove all external connections?
Is there a way to format the imported data as a table wthout breaking the connection ?
Thanks
Martin
This should work for you - make sure you have a tab called Data and you change the public const to the path of the file. I assume you know what to do with this code, if not let me know.
Public Const feedDir = "C:\Program Files\Common Files\System\data.csv" 'change this to the path of the file
Sub loadDataWrapper()
'''check file is in directory before proceding
If Dir(feedDir) <> "" Then
fileToLoad = feedDir
Else
MsgBox "No file available to load. Please check the path and try again."
Exit Sub
End If
Call loadData(fileToLoad)
End Sub
Sub loadData(ByVal fileToLoad As String)
Dim fso As Object, textFile As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim textFileStr As String
Dim textFileArr As Variant
Dim outputArr() As Variant
Dim oneRow As Variant
Dim numRows, numColumns As Long
'''open the text file and read into memory as is
Set textFile = fso.OpenTextFile(fileToLoad, 1)
textFileStr = textFile.ReadAll
textFile.Close
Set textFile = Nothing
Set fso = Nothing
'''find number of rows and columns of text file
textFileArr = Split(textFileStr, Chr(10))
numRows = UBound(textFileArr)
numColumns = UBound(Split(textFileArr(0), ","))
ReDim outputArr(numRows, numColumns)
'''go through every line and insert into array
For ii = 0 To (numRows - 1)
oneRow = Split(textFileArr(ii), ",")
For jj = 0 To numColumns
outputArr(ii, jj) = oneRow(jj)
Next jj
Next ii
'''output array to Worksheet
Worksheets("Data").Range("A2:Z1048576").ClearContents
Worksheets("Data").Range("A2").Resize(numRows + 1, numColumns + 1).Value = outputArr
End Sub
Would a Pivot Table satisfy your requirement?
Insert>PivotTable>Use External Data Source Radio Button