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.
Related
I am in the process of creating diagrams for multiple sites in our enterprise as part of an effort to implement a new technology. I have been gathering the information In an Excel document and from this document I have been able to update various Word documents and Excel documents using VBA, a picture of portion of my spreadsheet along with a sample of the Visio template and desired end state can be found below.
After searching through multiple websites, I was able to come up with the following code that will open the Visio Template, but I can't seem to get it to update the values as expected. As far as I can tell, I seem to be going through the various shapes, as I mentioned, the values are not updating as expected.
Thanks in advance for your help and advice.
Sub UpdateVisioTemplate()
Dim vDocs As Visio.Documents 'Documents collection of instance.
Dim vsoDoc As Visio.Document 'Document to work in
Dim vsoPage As Visio.Page 'Page to work in.
Dim vsoPages As Visio.Pages 'Pages collection of document.
Dim vApp As Visio.Application 'Declare an Instance of Visio.
Dim vsoShape As Visio.Shape 'Instance of master on page.
Dim vsoCharacters As Visio.Characters
Dim DiagramServices As Integer
Dim VarRow As Long
Dim FileName, DocName, VarName, VarValue, SiteID, SiteType, Wave, SiteName As String
'Dim vContent As Word.Range
With ActiveSheet
DocName = .Cells(1, 6).Value
SiteType = .Cells(1, 25).Value
SiteID = .Cells(20, 5).Value
SiteName = .Cells(21, 5).Value
On Error Resume Next 'Check if Visio is already running
'Set vApp = CreateObject("Visio.Application")
Set vApp = GetObject(, "Visio.Application")
If Err.Number <> 0 Then 'not equal to 0
Err.Clear
Set vApp = CreateObject("Visio.Application")
End If
vApp.Visible = True
Set vDocs = vApp.Documents.OpenEx(DocName, &H1)
'(DocName)
'Set vDocs = vApp.Documents.Open(DocName)
Set vsoPages = vApp.ActiveDocument.Pages
DiagramServices = vApp.ActiveDocument.DiagramServicesEnabled
vApp.ActiveDocument.DiagramServicesEnabled = visServiceVersion140
LastRow = .Range("A999").End(xlUp).Row
For Each vsoPage In vsoPages
For VarRow = 2 To LastRow 'from Row 2 to the last row
For Each vsoShape In vsoPage.Shapes
VarName = .Cells(VarRow, 1).Value 'VariableName
VarValue = .Cells(VarRow, 2).Value 'VariableValue
If Len(VarValue) = 0 Then 'If the variable value is blank, keep the variable in place
VarValue = .Cells(VarRow, 1).Value
End If
Set vsoCharacters = vsoShape.Charaters
vsoCharacters.Text = Replace(vsoCharacters.Text, VarName, VarValue) 'Find and replace the variables with the appropriate value
Next vsoShape
Next VarRow
Next vsoPage
End With 'Active Sheet
vDoc.SaveAs (SiteID & ".vsd")
End Sub
Sample of Excel Data
Visio Diagram Template
Visio Diagram Final
One thing I noticed was on the line Set vsoCharacters = vsoShape.Charaters - the latter should be vsoShape.Characters instead of Charaters - since this was essentially set to blank (nothing), then there was nothing to 'replace' and nothing changed.
The reason this did not appear is because the 'on error resume next' statement was made earlier which suppresses error messages and simply continues.
What I want to do
I have an Access database ( C:\Users\289894\Desktop\Database1.accdb )
One of the fields of [Table1] is [Memo].
That field is of the Memo data type, with the text format set to rich text.
It makes it possible to save some records as Bold and some records saved as Italics, for example.
I want to open a connexion to this Access database from an excel file in order to read/write into this rich text field.
The code I used is the following:
Dim datab As Database
Dim rs As Recordset
Dim path As String
path = "C:\Users\289894\Desktop\Database1.accdb"
Set datab = OpenDatabase(path)
Set rs = datab.OpenRecordset("SELECT * FROM [Table1]")
Debug.Print rs!Memo
Range("A1") = rs!Memo
My question
This code works well to open a connexion and read ordinary text fields, but rich text acts in a surprising way (for me). The original text in access was "aaa". That's "aaa" in bold font.
After running the code, both the debug.print and Range("A1") have <div><strong>aaa</strong></div> written into them.
How can I change my code to send the format to excel as well? I'd like to have "aaa" written in bold in cell A1, just like it is in Access.
EDIT: Workaround
This solves the immediate problem asked by the question without really answering the question itself. It uses internet explorer to paste the text back as Rich Text, without the tags.
Sub Sample()
Dim Ie As Object
Dim rng As Range
Set rng = Feuil1.Range("A1")
Set Ie = CreateObject("InternetExplorer.Application")
With Ie
.Visible = False
.Navigate "about:blank"
.Document.body.InnerHTML = rng.Value
.ExecWB 17, 0
'Select all contents in browser
.ExecWB 12, 2
'Copy them
ActiveSheet.Paste Destination:=rng
.Quit
End With
End Sub
Give this a shot. Loop range is generic. Also, function assumes very limited HTML as shown in your example.
Sub Test()
Dim cel As Range
For Each cel In Range("A1:A100")
cel.Font.Bold = InStr(1, cel.Value, "<strong>")
cel.Font.Italic = InStr(1, cel.Value, "<i>")
cel.Value = RemoveHTML(cel.Value)
Next
End Sub
Function RemoveHTML(sHTML As String) As String
Dim sTemp As String
sTemp = sHTML
Dim bLeft As Byte, bRight As Byte
bRight = InStr(1, sTemp, "</")
bLeft = InStrRev(sTemp, ">", bRight)
RemoveHTML = Mid(sTemp, bLeft + 1, bRight - bLeft - 1)
End Function
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.
Please help with the following:
1) A code that sets a list of all macros of "Module3", and place this list in "Sheet5", starting in cell "E14" below.
2) Then, the code should run all the listed macros
I tried with a code that referred VBComponent, but I got an error.
Based on my google search, I found the answer That I commented you , but They forgot and important thing, that is check and option to allow you run the macro.
First the Function to list all macros in excel and return and string separated by white space:
Function ListAllMacroNames() As String
Dim pj As VBProject
Dim vbcomp As VBComponent
Dim curMacro As String, newMacro As String
Dim x As String
Dim y As String
Dim macros As String
On Error Resume Next
curMacro = ""
Documents.Add
For Each pj In Application.VBE.VBProjects
For Each vbcomp In pj.VBComponents
If Not vbcomp Is Nothing Then
If vbcomp.CodeModule = "Module_name" Then
For i = 1 To vbcomp.CodeModule.CountOfLines
newMacro = vbcomp.CodeModule.ProcOfLine(Line:=i, _
prockind:=vbext_pk_Proc)
If curMacro <> newMacro Then
curMacro = newMacro
If curMacro <> "" And curMacro <> "app_NewDocument" Then
macros = curMacro + " " + macros
End If
End If
Next
End If
End If
Next
Next
ListAllMacroNames = macros
End Function
The next step, of well could be the first one, you need to change some configuration of the office (Excel) trustcenter, check the follow images:
Step 1:
Step 2:
Step 3 (Final) Check the option "rely on access to the data model project vba":
Then you need to add this reference to your Excel:
Don't worry if you have another version of Microsoft Visual Basic for Applications Extensibility, in this case is 5.3. Check and then accept.Don't forget that you need to find that reference, there is no on the top of the list.
Finally you can invoke the ListAllMacroNames ( ) function With This other macro named execute () , Look That I 'm Validated That doesn't call the same macros (execute , ListAllMacroNames ) or could make an infinite loop.
Public Sub execute()
Dim AppArray() As String
AppArray() = Split(ListAllMacroNames, " ")
For i = 0 To UBound(AppArray)
temp = AppArray(i)
If temp <> "" Then
If temp <> "execute" And temp <> "ListAllMacroNames" Then
Application.Run (AppArray(i))
Sheet5.Range("E" & i + 14).Value = temp
End If
End If
Next i
End Sub
EDIT 2 Change "Module_name" in first method, to your desire module, and set the corret sheet name (in this case Sheet 5) in execute method.
I have to know how can i link the excel database of Instrument loop Diagram in AutoCad format. I have AutoCad Template for a loop typical and Excel Database in which i have 100 Loops information for particular typical.I have AutoCad 2006,2007 and 2011 with me. please suggest idea for linking and generating he AutoCAD Drawings automatically.
The easiest way would be to learn a bit of AutoLisp, which is really worth learning if you're into generating drawings or automating your processes within AutoCAD.
Here's a great website for learning AutoLisp:
http://www.afralisp.net/index.php
AutoDesk's Lisp forum is also a great source of help.
As for extracting the data from Excel, here is a library which really facilitates access from AutoLisp:
http://download.cnet.com/KozMos-VLXLS/3000-2077_4-94214.html
'General rule: excel and acad have to be same like both 64bit or both 32 bit !!!
' You will need to add a reference to the AutoCAD
' Type Library to run this example book. Use the "Tools -
' References" menu. If you prefere you can switch to late
' binding by changeing the AutoCAD types to generic objects
Public Sub Excel_drives_acadPolyline_import_POINTs()
Dim objApp As AcadApplication
Dim objDoc As AcadDocument
Dim objEnt As AcadEntity
Dim varPnt As Variant
Dim strPrmpt As String
Dim intVCnt As Integer
Dim varCords As Variant
Dim varVert As Variant
Dim varCord As Variant
Dim varNext As Variant
Dim intCrdCnt As Integer
On Error GoTo Err_Control
Set objApp = AINTERFACE.Iapp
Set objDoc = objApp.activedocument
AppActivate objApp.CAPTION
objDoc.Utility.GetEntity objEnt, varPnt
If TypeOf objEnt Is AcadLWPolyline Then
AppActivate ThisDrawing.applicaTION.CAPTION
varCords = objEnt.COORDINATES
For Each varVert In varCords
intVCnt = intVCnt + 1
Next
For intCrdCnt = 0 To intVCnt / 2 - 1
varCord = objEnt.COORDINATE(intCrdCnt)
Excel.applicaTION.Cells(intCrdCnt + 1, 1).value = varCord(0)
Excel.applicaTION.Cells(intCrdCnt + 1, 2).value = varCord(1)
Next intCrdCnt
Else
MsgBox "Selected entity was not a LWPolyline"
End If
Exit_Here:
If Not objApp Is Nothing Then
Set objApp = Nothing
Set objDoc = Nothing
End If
Exit Sub
Err_Control:
'debug.print err.DESCRIPTION
Resume Exit_Here
End Sub
'----------------------------------------------------------------
' You will need to add a reference to the Excel
' Type Library to run this.In case of excel excel.exe is the library !
Sub acad-drives_excel()
Dim xAP As Excel.applicaTION
Dim xWB As Excel.Workbook
Dim xWS As Excel.WorkSheet
Set xAP = Excel.applicaTION
Set xWB = xAP.Workbooks.Open(SLOPEDIR.PROJECT & "\A2K2_VBA\IUnknown.xls")
Set xWS = xWB.Worksheets("Sheet1")
MsgBox "Excel says: """ & Cells(1, 1) & """"
Dim A2K As AcadApplication
Dim A2Kdwg As AcadDocument
Set A2K = AINTERFACE.Iapp
Set A2Kdwg = A2K.applicaTION.documents.Add
MsgBox A2K.NAME & " version " & A2K.version & _
" is running."
Dim HEIGHT As Double
Dim p(0 To 2) As Double
Dim TxtObj As ACADTEXT
Dim TxtStr As String
HEIGHT = 1
p(0) = 1: p(1) = 1: p(2) = 0
TxtStr = Cells(1, 1)
Set TxtObj = A2Kdwg.modelspace.AddText(TxtStr, _
p, HEIGHT)
A2Kdwg.SaveAs SLOPEDIR.PROJECT & "\A2K2_VBA\IUnknown.dwg"
A2K.documents.Close
A2K.Quit
Set A2K = Nothing
xAP.Workbooks.Close
xAP.Quit
Set xAP = Nothing
End Sub
Whatever way you choose now you can draw into the autocad drawing by using VBA.
There is another way for non programmers.
AUTOCAD SCRIPT
in fact you can create a excel table which creates this things and then you can export them to a text file. For simple task a solution but crap if you hase more complex things to do.
And last but not least you can create dynamic blocks and use vba to insert them and set the values of their parameters according to your excel sheet. But this would explode this tiny post