I am trying to build an organization chart automatically from data in Excel using Excel VBA. It works out fine, however, I would like to have both textframes filled in. In the big textframe I would like to have filled in the description of the department, and in the smaller textframe I would have like to add the department code.
smartart hierarchy layout
I can't find the code to access the smaller textframe.
Do While Source.Cells(Line, 1) <> ""
If Source.Cells(Line, 3) = PID Then
Set ParNode = QNode
If Source.Cells(Line, 4) = 1 Then
Set QNode = QNode.AddNode(msoSmartArtNodeDefault, msoSmartArtNodeTypeAssistant)
Else: Set QNode = QNode.AddNode(msoSmartArtNodeBelow)
End If
QNode.TextFrame2.TextRange.Text = Cells(Line, 6)
'here something needs to be added !!!
CurPid = Source.Cells(Line, 2)
If Not Found Then Found = True 'something was find
'Source.Rows(Line).Delete
'Line = Line + 1
Call AddChildNodes(QNode, Source, CurPid)
Debug.Print ("CurPid" & CurPid)
Debug.Print ("line" & Line)
Set QNode = ParNode
'ElseIf Found Then 'it's sorted,so nothing else can be found
' Exit Do
'Else
End If
Line = Line + 1
Loop
the upper line (where your CEO-text is)
QNode.TextFrame2.TextRange.Text
***.SmartArt.AllNodes(...).Shapes(1).TextFrame2.TextRange.Text
the lower line where your smartart is empty:
***.SmartArt.AllNodes(...).Shapes(2).TextFrame2.TextRange.Text
you need to check if QNode.Shapes(2).TextFrame2.TextRange.Text works. if not, you may need to use .parent
Related
I need some help with vba code. I'm self-lerning so please be understanding for simply cases ;)
I'm trying to create macro which will be looking for some records/cells in one workbook (FileA) (determined by 3 conditions) and then paste values to another workbook (FileB) and after that find in another tab in FileB some values where condition will be pasted value to match them with looking value (I belivie it could be done somehow with Vlookup but I get stuck).
Below problematic for me part of code (I'm working on some files found in work, no one use it now).
First issue is with Set Update, I don't know why it takes it as "Nothing"... conditions are true - I mean "pp1" is existing in column A in FileA.
Second issue shows when I change i start range to some "later" numbers, eg From i = 2280, macro is ignoring last line where should assign some values (again shows update2 as "nothing") but value if pp2 is existing in W column in tab data...
Dim name As String
name = "[path to file on sharepoint]"
Application.ScreenUpdating = False
Workbooks.Open Filename:=name
a = 1
For i = 2263 To 14000
If Workbooks("FileA").Sheets("Main").Cells(i, 11) = "CANCEL" And Workbooks("FileA").Sheets("Main").Cells(i, 6) = "DENIS" And Workbooks("FileA").Sheets("Main").Cells(i, 5) > 1301358454 Then
pp1 = Workbooks("FileA").Sheets("Main").Cells(i, 1)
If pp1 > 0 Then
Set Update = Workbooks("FileA").Worksheets("Main").Range("A:A").Find(pp1, lookat:=xlPart)
If Update > 0 Then
Update = Update.Row
Workbooks("FileB").Worksheets("lost").Cells(a, 1).Value = Workbooks("FileA").Worksheets("Main").Cells(Update, 5)
pp2 = Workbooks("FileB").Worksheets("lost").Cells(a, 1)
update2 = Workbooks("FileB").Worksheets("data").Range("W:W").Find(pp2, lookat:=xlPart).Row
Workbooks("FileB").Worksheets("lost").Cells(a, 5) = Workbooks("FileB").Worksheets("data").Cells(update2, 43)
I have a sigle column ComboBox that I have populated with a dynamic array; however, I'd like the code to replace the value of the combo box with respective column from my ListBox.
'Prepares the Active Escorts list box.
ivb = 0
i = 0
With frmEntry
.listboxActiveEscorts.Clear
.listboxActiveEscorts.ColumnHeads = False
.listboxActiveEscorts.ColumnCount = "15"
.listboxActiveEscorts.ColumnWidths = "0,100,100,0,0,100,100,0,0,0,0,0,100,100,80"
i = 0
'Badge # combobox properties
ReDim vbArray(0 To vbArrayCount - 1)
For i = 0 To vbArrayCount - 1
ivb = ivb + 1
vbArray(ivb - 1) = loVisBadge.Range.Cells(i + 2, 1).Value
Next i
.cbxVisitorBadgeNumber.List = vbArray
End With
This population of the ComboBox executes beautifully, in my belief, but if you see a better way to implement the dynamic list, I'm all ears.
I have a button that I will use to reset the form, which also works for the most part. When an item is selected from the list, I am able to clear all controls except for the ComboxBox containing the array of values. I will be adding two additional arrays to each of the other ComboBoxes on the form, and I imagine I am going to have the same problem: "Could not set the value property. Invalid property value"
This is the code assigned to click event of the ListBox:
Private Sub listboxActiveEscorts_Click()
With frmEntry
.cbxEscortSelectName.Value = .listboxActiveEscorts.Column(1) + " " + .listboxActiveEscorts.Column(2)
.txtCredential.Value = .listboxActiveEscorts.Column(4)
.txtEscortCompany.Value = .listboxActiveEscorts.Column(3)
.cbxVisitorName.Value = .listboxActiveEscorts.Column(5) + " " + .listboxActiveEscorts.Column(6)
.txtVECompany.Value = .listboxActiveEscorts.Column(7)
.txtVEDOB.Value = .listboxActiveEscorts.Column(8)
.txtVEIdentification.Value = .listboxActiveEscorts.Column(9)
.txtVEIDNumber.Value = .listboxActiveEscorts.Column(10)
.txtVEExpirationDate.Value = .listboxActiveEscorts.Column(11)
.txtVEStart.Value = .listboxActiveEscorts.Column(12)
.txtVEEnd.Value = .listboxActiveEscorts.Column(13)
'.cbxVisitorBadgeNumber.Value = ""
.cbxVisitorBadgeNumber = vbNullString
.cbxVisitorBadgeNumber.Value = .listboxActiveEscorts.Column(14)
End With
End Sub
What am I missing here. I tried to ReDim the array that assigned the values, but that didn't work. Is it a data type thing, perhaps?
In the picture below, you'll see the values populated in the controls, all except the visitor badge # (ComboBox which throws the error...I have commented out the line for illustration purposes, so you'll see the visitor badge # is blank).
I'm reading from a text file and I can't see all the lines. I can see the value of the text line because it shows up in the
View->Locals Window. While debugging, I hover of the variable that holds the line of text and see what the value is.
Example:
This line works: * CALIBRATION DATA - YF079305 0490-0310-5338 *
When I hover over txtStream, after reading the line above, it shows up correctly.
This line doesn't: 8.41 25.34 2.29 1.04 1131 1156 65.54.
When I hover over txtStream it reads nothing. When I pull the Local Windows it shows that the data is there.
My hypothesis: There's something I don't know about reading text lines that start with a number. I'm still working on this but I'm pretty stumped.
Code attached for investigation:
Dim fso As Variant: Set fso = CreateObject("Scripting.FileSystemObject")
Dim txtStream As Variant: Set txtStream = fso.OpenTextFile(FileAndPath, ForReading, False)
Do While Not txtStream.AtEndOfStream
LineFromFile = txtStream.ReadLine
' Data caputre, one line
For a1 = 0 To searchLen
If (InStr(1, searchTerms(a1), LineFromFile) > 1) Then
dataLine = Split(LineFromFile, vbTab)
' Data organize
For a2 = 0 To dataLen
dataArray(a1, a2) = dataLine(k + dataOffset)
Next a2
' Final data found
If (a1 = searchLen) Then
finalData = True
End If
End If
If (finalData = True) Then
finalData = False
For a3 = searchLen To 0
For a4 = 0 To dataLen
Cells(dataRowOffset, dataColumnOffset + a4).Value = dataArray(a3, dataColumnOffset + a4)
Next a4
dataColumnOffset = dataColumnOffset + dataLen
Next a3
End If
Next a1
Loop
txtStream.Close
APOLOGIES TO THE COMMUNITY! I just found out what was going on, it was two fold.
Where I put my breakpoint was wrong. It was showing me the previous text line, not the most current one.
I didn't understand that If (InStr(1, , searchTerms(a1)) > 1) Then
was not the same as If (InStr(1, LineFromFile, searchTerms(a1)) > 0) Then. I was finding the searchTerm in the 1 position. And 1 is not greater than 1. My bad.
The input file may contain nonprinting chars especially when created under another opsys. You might consider using ReadAll instead of ReadLine, then Split the file by record separator, and apply Worksheetfunction.Clean() to clear the nonprinting chars, like this:
CompleteFile = txtStream.ReadAll
LineBuf = Split (CompleteFile, vbCrLf) ' or whatever the record separator is
For Each LineFromFile in LineBuf
LineFromFile = worksheetfunction.Clean(LineFromFile)
For a1 = 0 To searchLen ....
In general, when you run into misterious problems working with files created under another opsys or even another version of Windows, the most obvious bug is a different encoding (ASCII vs Unicode, national characters, vbLf vs vbCrLf). You might check the input file with a hex editor to have a deeper insight. Anyhow, the easiest check at the very beginning is to see how VBA reads the records:
Do While Not txtStream.AtEndOfStream
LineFromFile = txtStream.ReadLine
i = i + 1
Debug.Print CStr(i) & ": ***" & LineFromFile & "***"
Loop
I am trying to extract tables from pdf files with vba and export them to excel. If everything works out the way it should, it should go all automatic. The problem is that the table are not standardized.
This is what I have so far.
VBA (Excel) runs XPDF, and converts all .pdf files found in current folder to a text file.
VBA (Excel) reads through each text file line by line.
And the code:
With New Scripting.FileSystemObject
With .OpenTextFile(strFileName, 1, False, 0)
If Not .AtEndOfStream Then .SkipLine
Do Until .AtEndOfStream
//do something
Loop
End With
End With
This all works great. But now I am getting to the issue of extracting the tables from the text files.
What I am trying to do is VBA to find a string e.g. "Year's Income", and then output the data, after it, into columns. (Until the table ends.)
The first part is not very difficult (find a certain string), but how would I go about the second part. The text file will look like this Pastebin. The problem is that the text is not standardized. Thus for example some tables have 3-year columns (2010 2011 2012) and some only two (or 1), some tables have more spaces between the columnn, and some do not include certain rows (such as Capital Asset, net).
I was thinking about doing something like this but not sure how to go about it in VBA.
Find user defined string. eg. "Table 1: Years' Return."
a. Next line find years; if there are two we will need three columns in output (titles +, 2x year), if there are three we will need four (titles +, 3x year).. etc
b. Create title column + column for each year.
When reaching end of line, go to next line
a. Read text -> output to column 1.
b. Recognize spaces (Are spaces > 3?) as start of column 2. Read numbers -> output to column 2.
c. (if column = 3) Recognize spaces as start of column 3. Read numbers -> output to column 3.
d. (if column = 4) Recognize spaces as start of column 4. Read numbers -> output to column 4.
Each line, loop 4.
Next line does not include any numbers - End table. (probably the easiet just a user defined number, after 15 characters no number? end table)
I based my first version on Pdf to excel, but reading online people do not recommend OpenFile but rather FileSystemObject (even though it seems to be a lot slower).
Any pointers to get me started, mainly on step 2?
You have a number of ways to dissect a text file and depending on how complex it is might cause you to lean one way or another. I started this and it got a bit out of hand... enjoy.
Based on the sample you've provided and the additional comments, I noted the following. Some of these may work well for simple files but can get unwieldy with bigger more complex files. Furthermore, there may be slightly more efficient methods or tricks to what I have used here but this will definitely get you going an achieve the desired outcome. Hopefully this makes sense in conjunction with the code provided:
You can use booleans to help you determine what 'section' of the text file you are in. Ie use InStr on the current line to
determine you are in a Table by looking for the text 'Table' and then
once you know you are in the 'Table' section of the file start
looking for the 'Assets' section etc
You can use a few methods to determine the number of years (or columns) you have. The Split function along with a loop will do
the job.
If your files always have constant formatting, even only in certain parts, you can take advantage of this. For example, if you know your
file line will always have a dollar sign in front of the them, then
you know this will define the column widths and you can use this on
subsequent lines of text.
The following code will extract the Assets details from the text file, you can mod it to extract other sections. It should handle multiple rows. Hopefully I've commented it sufficient. Have a look and I'll edit if needs to help out further.
Sub ReadInTextFile()
Dim fs As Scripting.FileSystemObject, fsFile As Scripting.TextStream
Dim sFileName As String, sLine As String, vYears As Variant
Dim iNoColumns As Integer, ii As Integer, iCount As Integer
Dim bIsTable As Boolean, bIsAssets As Boolean, bIsLiabilities As Boolean, bIsNetAssets As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
sFileName = "G:\Sample.txt"
Set fsFile = fs.OpenTextFile(sFileName, 1, False)
'Loop through the file as you've already done
Do While fsFile.AtEndOfStream <> True
'Determine flag positions in text file
sLine = fsFile.Readline
Debug.Print VBA.Len(sLine)
'Always skip empty lines (including single spaceS)
If VBA.Len(sLine) > 1 Then
'We've found a new table so we can reset the booleans
If VBA.InStr(1, sLine, "Table") > 0 Then
bIsTable = True
bIsAssets = False
bIsNetAssets = False
bIsLiabilities = False
iNoColumns = 0
End If
'Perhaps you want to also have some sort of way to designate that a table has finished. Like so
If VBA.Instr(1, sLine, "Some text that designates the end of the table") Then
bIsTable = False
End If
'If we're in the table section then we want to read in the data
If bIsTable Then
'Check for your different sections. You could make this constant if your text file allowed it.
If VBA.InStr(1, sLine, "Assets") > 0 And VBA.InStr(1, sLine, "Net") = 0 Then bIsAssets = True: bIsLiabilities = False: bIsNetAssets = False
If VBA.InStr(1, sLine, "Liabilities") > 0 Then bIsAssets = False: bIsLiabilities = True: bIsNetAssets = False
If VBA.InStr(1, sLine, "Net Assests") > 0 Then bIsAssets = True: bIsLiabilities = False: bIsNetAssets = True
'If we haven't triggered any of these booleans then we're at the column headings
If Not bIsAssets And Not bIsLiabilities And Not bIsNetAssets And VBA.InStr(1, sLine, "Table") = 0 Then
'Trim the current line to remove leading and trailing spaces then use the split function to determine the number of years
vYears = VBA.Split(VBA.Trim$(sLine), " ")
For ii = LBound(vYears) To UBound(vYears)
If VBA.Len(vYears(ii)) > 0 Then iNoColumns = iNoColumns + 1
Next ii
'Now we can redefine some variables to hold the information (you'll want to redim after you've collected the info)
ReDim sAssets(1 To iNoColumns + 1, 1 To 100) As String
ReDim iColumns(1 To iNoColumns) As Integer
Else
If bIsAssets Then
'Skip the heading line
If Not VBA.Trim$(sLine) = "Assets" Then
'Increment the counter
iCount = iCount + 1
'If iCount reaches it's limit you'll have to redim preseve you sAssets array (I'll leave this to you)
If iCount > 99 Then
'You'll find other posts on stackoverflow to do this
End If
'This will happen on the first row, it'll happen everytime you
'hit a $ sign but you could code to only do so the first time
If VBA.InStr(1, sLine, "$") > 0 Then
iColumns(1) = VBA.InStr(1, sLine, "$")
For ii = 2 To iNoColumns
'We need to start at the next character across
iColumns(ii) = VBA.InStr(iColumns(ii - 1) + 1, sLine, "$")
Next ii
End If
'The first part (the name) is simply up to the $ sign (trimmed of spaces)
sAssets(1, iCount) = VBA.Trim$(VBA.Mid$(sLine, 1, iColumns(1) - 1))
For ii = 2 To iNoColumns
'Then we can loop around for the rest
sAssets(ii, iCount) = VBA.Trim$(VBA.Mid$(sLine, iColumns(ii) + 1, iColumns(ii) - iColumns(ii - 1)))
Next ii
'Now do the last column
If VBA.Len(sLine) > iColumns(iNoColumns) Then
sAssets(iNoColumns + 1, iCount) = VBA.Trim$(VBA.Right$(sLine, VBA.Len(sLine) - iColumns(iNoColumns)))
End If
Else
'Reset the counter
iCount = 0
End If
End If
End If
End If
End If
Loop
'Clean up
fsFile.Close
Set fsFile = Nothing
Set fs = Nothing
End Sub
I cannot examine the sample data as the PasteBin has been removed. Based on what I can glean from the problem description, it seems to me that using Regular Expressions would make parsing the data much easier.
Add a reference to the Scripting Runtime scrrun.dll for the FileSystemObject.
Add a reference to the Microsoft VBScript Regular Expressions 5.5. library for the RegExp object.
Instantiate a RegEx object with
Dim objRE As New RegExp
Set the Pattern property to "(\bd{4}\b){1,3}"
The above pattern should match on lines containing strings like:
2010
2010 2011
2010 2011 2012
The number of spaces between the year strings is irrelevant, as long as there is at least one (since we're not expecting to encounter strings like 201020112012 for example)
Set the Global property to True
The captured groups will be found in the individual Match objects from the MatchCollection returned by the Execute method of the RegEx object objRE. So declare the appropriate objects:
Dim objMatches as MatchCollection
Dim objMatch as Match
Dim intMatchCount 'tells you how many year strings were found, if any
Assuming you've set up a FileSystemObject object and are scanning the text file, reading each line into a variable strLine
First test to see if the current line contains the pattern sought:
If objRE.Test(strLine) Then
'do something
Else
'skip over this line
End If
Set objMatches = objRe.Execute(strLine)
intMatchCount = objMatches.Count
For i = 0 To intMatchCount - 1
'processing code such as writing the years as column headings in Excel
Set objMatch = objMatches(i)
e.g. ActiveCell.Value = objMatch.Value
'subsequent lines beneath the line containing the year strings should
'have the amounts, which may be captured in a similar fashion using an
'additional RegExp object and a Pattern such as "(\b\d+\b){1,3}" for
'whole numbers or "(\b\d+\.\d+\b){1,3}" for floats. For currency, you
'can use "(\b\$\d+\.\d{2}\b){1,3}"
Next i
This is just a rough outline of how I would approach this challenge. I hope there is something in this code outline that will be of help to you.
Another way to do this I have some success with is to use VBA to convert to a .doc or .docx file and then search for and pull tables from the Word file. They can be easily extracted into Excel sheets. The conversion seems to handle tables nicely. Note however that it works on a page by page basis so tables extending over a page end up as separate tables in the word doc.
Details:
In this segment, I am filling the cell referenced by 'z' with modified date values from cell referenced by 'a', depending on the conditions met. The code crashes at the inner End If line.
Code snippet:
If Range(x).Value =1 Then
If Day(Range(a)) > Day(Range(b)) Then
Range(z).Value = DateSerial(Year(Range(a)), Month(Range(a)), Day(Range(a)-1)) + TimeSerial(20,0,0)
Else
Range(z).Value = DateSerial(Year(Range(a)), Month(Range(a)), Day(Range(a))) + TimeSerial(20,0,0)
End If
ElseIf Range(y).Value =1 Then
Range(z).Value = DateSerial(Year(Range(a)), Month(Range(a)), Day(Range(a)-1)) + TimeSerial(8,0,0)
Else
Range(z).Value = Range(a).Value
End If
Your code is good. Either you have a problem where one of your ranges is pointing to invalid data, or you have corruption in your module.
You can handle corruption by exporting your moodules to a text file (right click module in VBA editor->export) and then import into a clean workbook.
It seems to test fine for me.
I know default properties have been created in order to make code more concise, and I realize objects should not need to be fully qualified with their parent objects but I don't always trust the VBA compiler so my version is a little longer than yours (I've used the cells C1 to C5 to test):
Option Explicit
Sub FullyQualified()
With Excel.ThisWorkbook.Sheets("Sheet1")
If .Range("C1").Value = 1 Then
If Day(.Range("C3").Value) > Day(.Range("C4").Value) Then
.Range("C5").Value = DateSerial(Year(.Range("C3").Value), Month(.Range("C3").Value), Day(.Range("C3").Value - 1)) + TimeSerial(20, 0, 0)
Else
.Range("C5").Value = DateSerial(Year(.Range("C3").Value), Month(.Range("C3").Value), Day(.Range("C3").Value)) + TimeSerial(20, 0, 0)
End If
ElseIf .Range("C2").Value = 1 Then
.Range("C5").Value = DateSerial(Year(.Range("C3").Value), Month(.Range("C3").Value), Day(.Range("C3").Value - 1)) + TimeSerial(8, 0, 0)
Else
.Range("C5").Value = .Range("C3").Value
End If
End With
End Sub