I have code that gets the range of each heading in a word document. The headings' ranges are saved in HeadingRange(). I am getting Run-Type Error 13: type mismatch when I set HeadingRange(HeadingCount) in my For loop. I don't know why this is happening. Both HeadingRange() and wrdApp.Selection.Range are clearly instances of the Range class.
Private Sub WordTab()
Dim wrdDoc As Word.Document
Dim wrdApp As Word.Application
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:/Test.docx")
Dim i As Integer
Dim myHeadings As Variant
Dim count As Integer
Dim HeadingRange() As Range
Dim HeadingCount as Integer
TableCount = wrdDoc.Tables.count
wrdApp.Selection.HomeKey Unit:=wdStory 'moves selection to beginning of doc. assuming document's first line is not a heading.
myHeadings = wrdDoc.GetCrossReferenceItems(wdRefTypeHeading)
HeadingCount = 1
For i = LBound(myHeadings) To UBound(myHeadings) 'iterate through all headings
wrdApp.Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext 'move selection to next heading.
wrdApp.Selection.Expand wdLine 'expand selection range to entire line
ReDim Preserve HeadingRange(1 To HeadingCount)
Set HeadingRange(HeadingCount) = wrdApp.Selection.Range 'This is where the type mismatch happens
HeadingCount = HeadingCount + 1
Next i
wrdDoc.Close (Word.WdSaveOptions.wdDoNotSaveChanges)
Debug.Print "Done"
End Sub
Redimension the Array to some dummy size first. You are trying to Preserve a non-existent array.
So you could add a
Redim HeadingRange(1 To 1)
code at the start, before your loop begins.
Related
I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows and apply hidden formatting on it but it selects only the first rows of the merged cell, not the whole row.
Below is the result that I am getting.
But I am seeking a result that will hide all content in 4 columns but I am unable to find a solution for the same.
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\New folder\Episode_0_intro_UEFA_v1_EN.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("Slide Notes")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Rows.Select
WrdApp.Selection.Font.Hidden = True
WrdApp.Selection.Range.HighlightColorIndex = wdBlue
'WrdApp.Selection.Range.Next.Rows.Select
'WrdApp.Selection.Font.Hidden = True
'WrdApp.Selection.Range.HighlightColorIndex = wdBlue
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where I am doing the issue so, I can rectify it?
I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows but when I try to apply the Hidden behavior on the whole row then VBA through an error.
Getting error on below the line
Selection.Font.Hidden = True
Below is my whole code
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\DE\DE\International_DE.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("French", "Spanish")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Select
Selection.Font.Hidden = True
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where i am doing issue so, i can rectify it.
I think it's more effective to reduce the row height to an exact minimum value.
Something like this works for me.
Sub Test()
SearchArr = Array("sdg", "sdh", "dsf")
'loop tables
For Cnt = 1 To ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each tblCell In ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = tblCell.Range
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).HeightRule = wdRowHeightExactly
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).Height = 1
End If
Next tblCell
Next Arrcnt
Next Cnt
End Sub
Three issues.
This code is running in 4-5 minutes for me with the database that I currently have. Normally it will be a database with 100~ columns. I want to make this faster.
Another issue I have is that I keep getting two different pop-ups:
"File now Available for Editing"
"User is currently editing workbook, would you like to run in read-only mode?"
Very annoying, but nothing I can't live with.
Lastly, I also sometimes get an error on this line:
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse But all I have to do is re-run the program and it'll go away.
I'm looking for any suggestions to make this code run a little faster and smoother, any recommendations are welcome.
Thanks!
Public Sub averageScoreRelay()
' 1. Run from PPT and open an Excel file
' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56,iq_72".
' 3. find those words and numbers in the opened Excel file after splitting and re-formating string.
' 3. Copy column into a new sheets and repeat for all "iq_'s" until sheets 2 has a table.
' 4. Copy table from xl Paste Table into ppt
' 5. Do this for every slide
'Timer start
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim pptSlide As Slide
Dim Shpe As Shape
Dim pptText As String
Dim pptPres As Object
Dim iq_Array As Variant
Dim arrayLoop As Integer
Dim i As Integer
Dim myShape As Object
Dim colNumb As Integer
Dim size As Integer
Dim k As Integer
Dim lRows As Long
Dim lCols As Long
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
'xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("file.xlsx", True, False, , , , True, Notify:=False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
xlApp.DisplayAlerts = False
With xlWB.Worksheets("Sheet1")
colNumb = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'Create a new blank Sheet in excel, should be "Sheet2"
xlWB.Worksheets.Add After:=xlWB.ActiveSheet
'Make pptPres the ppt active
Set pptPres = PowerPoint.ActivePresentation
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
pptSlide.Select
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
k = 1
'Identify if there is text frame
If Shpe.HasTextFrame Then
'Identify if there's text in text frame
If Shpe.TextFrame.HasText Then
'Set pptText as the Text in the box, then make it lowercase and trim Spaces and Enters
pptText = Shpe.TextFrame.TextRange
pptText = LCase(Replace(pptText, " ", vbNullString))
pptText = Replace(Replace(Replace(pptText, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)
'Identify if within text there is "iq_"
If InStr(1, pptText, "iq_") > 0 Then
'set iq_Array as an array of the split iq's
iq_Array = Split(pptText, ",")
'Find size of the array
size = UBound(iq_Array) - LBound(iq_Array)
'loop for each iq_ in the array'
For arrayLoop = 0 To size
'Statement that will take iq_'s in the form "iq_9" or "iq_99" or "iq_999"
If iq_Array(arrayLoop) Like "iq_#" Or iq_Array(arrayLoop) Like "iq_##" Or iq_Array(arrayLoop) Like "iq_###" Then
'loops for checking each column
For i = 1 To colNumb
'Copies the first column (role column) for every slide that needs it
If i = 1 And arrayLoop = 0 Then
'copy column
xlWB.Worksheets("Sheet1").Columns(1).Copy
'paste column in Sheet2 which was newly created
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(1)
'If this is not the role column, then check to see if the iq_'s match from ppt to xl
ElseIf xlWB.Worksheets("Sheet1").Cells(1, i) = iq_Array(arrayLoop) And i <> 1 Then
'Serves to paste in the next column of Sheet2 so that we end up with a table
k = k + 1
'same as above
xlWB.Worksheets("Sheet1").Columns(i).Copy
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(k)
'Go to next array
GoTo Line2
End If
Next i
'Same as above, just this one is for iq_'s with form "iq_45,46,47" instead of "iq_45,iq_46,iq_47"
ElseIf (iq_Array(0) Like "iq_#" Or iq_Array(0) Like "iq_##" Or iq_Array(0) Like "iq_###") And (IsNumeric(iq_Array(arrayLoop)) And Len(iq_Array(arrayLoop)) <= 3) Then
For i = 1 To colNumb
If i = 1 And arrayLoop = 0 Then
xlWB.Worksheets("Sheet1").Columns(1).Copy
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(1)
ElseIf xlWB.Worksheets("Sheet1").Cells(1, i) = ("iq_" & iq_Array(arrayLoop)) And i <> 1 Then 'if iq in ppt = iq in xl and if not the first cell then execute
k = k + 1
xlWB.Worksheets("Sheet1").Columns(i).Copy
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(k)
GoTo Line2
End If
Next i
End If
Line2:
Next arrayLoop
End If
End If
End If
Next Shpe
'calculate last row and last column on sheet2. aka. find Table size
With xlWB.Worksheets("Sheet2")
lRows = .Cells(.Rows.Count, 1).End(xlUp).Row
lCols = .Cells(1, .Columns.Count).End(xlToLeft).Column
'If only one column then go to next slide
If lRows = .Cells(1, 1).End(xlUp).Row And lCols = .Cells(1, 1).End(xlToLeft).Column Then
GoTo Line1
End If
'Copy table
.Range(.Cells(1, 1), .Cells(lRows, lCols)).Copy
End With
'Paste Table into ppt
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse
'Recently pasted shape is the last shape on slide, so it will be the same as count of shapes on slide
Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count)
'Set position:
myShape.Left = -200
myShape.Top = 200
'Clear Sheet2 for next slide
xlWB.Worksheets("Sheet2").Range("A1:P10").Clear
Line1:
Next pptSlide
xlWB.Worksheets("Sheet2").Delete
xlWB.Close
xlApp.Quit
xlApp.DisplayAlerts = True
'End Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
I have this Word VBA code, which removes field codes, but retains their values. This works well, but not in the header. How can I edit it to work for the body of document ( and header/footer as well ) ?
Sub RemoveFieldCodeButRetainValue()
Dim d As Document
Dim iTemp As Integer
Dim strTemp As String
Set d = ActiveDocument
For iTemp = d.Fields.Count To 1 Step -1
strTemp = d.Fields(iTemp).Result
d.Fields(iTemp).Select
With Selection
.Fields(1).Delete
.TypeText strTemp
End With
Next
End Sub
Sorry, I realize this isn't exactly the answer to the question, but using:
For Each fld In ActiveDocument.Fields
fld.Unlink
Next
will preserve the value while deleting the underlying field. As far as I know, you could use the same technique while looping through the various story ranges as suggested in the other answer for the header/footer areas.
ok, I got it:
Use two macros:
Sub CtrlAPlusFNine()
Selection.WholeStory
Dim oStory As Range
For Each oStory In ActiveDocument.StoryRanges
oStory.Fields.Update
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
oStory.Fields.Update
Wend
End If
Next oStory
lbl_Exit:
Set oStory = Nothing
Exit Sub
End Sub
Sub RemoveFieldCodeButRetainValue()
Dim d As Document
Dim iTemp As Integer
Dim strTemp As String
Set d = ActiveDocument
For iTemp = d.Fields.Count To 1 Step -1
strTemp = d.Fields(iTemp).Result
d.Fields(iTemp).Select
With Selection
.Fields(1).Delete
.TypeText strTemp
End With
Next
End Sub
..and call these two from a third macro using Application.Run
I would like to get some VBA code which would tell me the number of sheets in a Catia drawing. Each sheet would have a title block placed on it. A text field on each title block would communicates the number of sheets. So if you had three sheets in the drawing you would have 1 of 3 (in the title block sheet 1) 2 of 3 (in the title block shhet 2) and 3 of 3 (in the title block sheet 3). If the macro could update all title blocks on all sheets automatically.
Any help much appreciated.
The concept is to loop through all of the DrawingSheet objects in the Sheets collection of the DrawingDocument you should put all title block elements in the "Background View". Next we need to update or create existing title block text elements. These are DrawingText objects. We try to access the DrawingText by name(THIS MUST BE UNIQUE!). If it does not exist, we create it. If it does exist, we update the value.
Here's a start to making your title block:
Option Explicit
Sub UpdateSheetPage()
Dim DrawingDoc As DrawingDocument
Dim DSheet As DrawingSheet
Dim DView As DrawingView
Dim SheetCount As Integer
Dim currentSheet As Integer
'the drawing must be the active docuement window or this will fail. you can do more error checking if needed
On Error GoTo ExitSub
Set DrawingDoc = CATIA.ActiveDocument
SheetCount = DrawingDoc.Sheets.Count
currentSheet = 1 'initialize sheet number
'loop through all sheets and update or create a sheet number
For Each DSheet In DrawingDoc.Sheets
UpdatePageNumber DSheet, currentSheet, SheetCount
currentSheet = currentSheet + 1
Next
ExitSub:
End Sub
Sub UpdatePageNumber(currentDrawingSheet As DrawingSheet, currentSheetNumber As Integer, totalSheets As Integer)
Dim sheetNumber As String
Dim xPos, yPos As Long 'mm
'edit these if needed
xPos = 100 'edit this - only use for new creation
yPos = 100 'edit this
'display format
sheetNumber = "Page " & currentSheetNumber & "/" & totalSheets
Dim backgroundView As DrawingView
Dim dTexts As DrawingTexts
Dim currentText As DrawingText
Set backgroundView = currentDrawingSheet.Views.Item("Background View")
Set dTexts = backgroundView.Texts
On Error GoTo CreateNew
Set currentText = dTexts.GetItem("SheetNumber")
currentText.Text = sheetNumber
Exit Sub
CreateNew:
Set currentText = dTexts.Add(sheetNumber, xPos, yPos)
currentText.Name = "SheetNumber" 'so we can access it later for an update
End Sub