I have about 50 files that were done in Publisher 98 or 2000 that I am now opening in Publisher 2016 (or whatever the current version is with office 365)? Anyway all the textboxes that contain the font Comic Sans MS (about 40 in each file) need to have the line spacing changed from 1sp to 1.3sp to get it to flow the same way it did originally. How do I change the line spacing once I have the text selected?
Sub fixPulications()
Dim PubApp As Application
Dim PubDocs As Documents
Dim PubDoc As Document
Dim MyDocs As Long
Dim MyDoc As Long
Dim PubPages As Pages
Dim PubPage As Page
Dim MyPages As Long
Dim MyPage As Long
Dim PubShapes As Shapes
Dim PubShape As Shape
Dim MyShapes As Long
Dim MyShape As Long
Dim MyFileName As String
Set PubApp = Application
Set PubDocs = Application.Documents
Set PubDoc = Application.ActiveDocument
Set PubPages = PubDoc.Pages
MyDocs = PubDocs.Count
MyDoc = 0
MyPage = 0
MyShape = 0
Do While MyDoc < MyDocs - 1
Set PubDoc = Application.Documents(2)
MyFileName = PubDoc.FullName
MyPages = PubPages.Count
Do While MyPage < MyPages
MyPage = MyPage + 1
Set PubPage = PubDoc.Pages(MyPage)
MyShapes = PubShapes.Count
Do While MyShape < MyShapes
MyShape = MyShape + 1
Set PubShape = PubPage.Shapes(MyShape)
If PubShape.HasTextFrame Then
If PubShape.TextFrame.TextRange.Font = "Comic Sans MS" Then
With PubShape.TextFrame.TextRange.Story
' I can't figure out the correct syntax of the folowing line.
PubShape.TextFrame.TextRange.ParagraphFormat.LineSpacing (1.3)
End With
End If
End If
Loop
MyShape = 0
Loop
MyPage = 0
MyDoc = MyDoc + 1
PubDoc.SaveAs (MyFileName & "_R.pub")
PubDoc.Close
Loop
End Sub
Try to set value as Publisher documentation recommends:
...
...TextRange.ParagraphFormat.LineSpacing = 1.3 'not sure if non-integer value is valid
...
I am trying to create a macro which copies the text from all the tables in a slide. I can select the tables but failed to copy text entries from tables. I need to paste the copied text to a excel spreadsheet.
Here is the script:
Option Explicit
Sub GetTableNames()
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Dim pptSlide As Slide
Set pptSlide = Application.ActiveWindow.View.Slide
Dim pptShapes As Shape
Dim pptTable As Table
For Each pptSlide In pptpres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.HasTable Then
Set pptTable = pptShapes.Table
pptShapes.Select msoFalse
pptShapes.TextFrame.TextRange.Copy
End If
Next
Next
End Sub
enter image description here
enter image description here
Try this code:
Sub GetTableNames()
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Dim pptSlide As Slide
Set pptSlide = Application.ActiveWindow.View.Slide
Dim pptShapes As Shape, pptTable As Table
Dim XL As Object, WS As Object
Dim arr As Variant, nextTablePlace As Integer, cnt As Integer
Set XL = CreateObject("Excel.Application")
With XL.Workbooks.Add
Set WS = .Worksheets(1)
End With
nextTablePlace = 1 ' to output first table content into Worksheet
For Each pptSlide In pptpres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.HasTable Then
cnt = cnt + 1
Set pptTable = pptShapes.Table
WS.Cells(nextTablePlace, 1) = "Table #: " & cnt ' caption for each table
nextTablePlace = nextTablePlace + 1
ReDim arr(1 To pptTable.Rows.Count, 1 To pptTable.Columns.Count) ' resize array to table dimensions
For rr = 1 To pptTable.Rows.Count
For cc = 1 To pptTable.Columns.Count
arr(rr, cc) = pptTable.Cell(rr, cc).Shape.TextFrame.TextRange.Text 'get text from each cell into array
Next
Next
' flush the arr to Worksheet
WS.Cells(nextTablePlace, 1).Resize(pptTable.Rows.Count, pptTable.Columns.Count) = arr
' to next place with gap
nextTablePlace = nextTablePlace + pptTable.Rows.Count + 2
End If
Next
Next
XL.Visible = True
End Sub
Hey everyone I found this awesome code that helped me get the loop I needed but I am trying to alter this to extract all the data from the word tables not just one row of the tables.. Any help would be great. I know it going to be a simple fix just haven't been able to get any to work on my own. Thanks
Sub wordScrape()
Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files
x = 1
For Each wd In objFiles
If InStr(wd, ".docx") And InStr(wd, "~") = 0 Then
Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)
sh1.Cells(x, 1) = wd.Name
sh1.Cells(x, 2) = Application.WorksheetFunction.Clean(wrdDoc.Tables(3).Cell(Row:=3, Column:=2).Range)
'sh1.Cells(x, 3) = ....more extracted data....
x = x + 1
wrdDoc.Close
End If
Next wd
wordApp.Quit
End Sub`
Sub wordScrape()
Dim wd As New Word.Application
Dim wdDoc As Word.Document
Dim tbl As Word.Table
Dim sh1 As Worksheet
Dim x As Integer
Dim y As Integer
Dim s As String
Dim r As Range
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set r = sh1.Range("a1")
s = Dir(FolderName & "\*.doc*")
Do While s <> ""
If InStr(wd, "~") = 0 Then
Set wdDoc = wd.Documents.Open(FolderName & "\" & s, False, True, False)
For Each tbl In wdDoc.Tables
For x = 1 To t.Rows.Count
r = wdDoc.Name
For y = 1 To t.Columns.Count
r.Offset(0, y) = Application.WorksheetFunction.Clean(t.Cell(Row:=x, Column:=y).Range)
Next y
Set r = r.Offset(1, 0)
Next x
Next tbl
wdDoc.Close False
End If
s = Dir()
Loop
End Sub
Now, this is off the top of my head, it assumes a reference to word is set (tools,references in the VBE) and it crucially assumes that every table has no merged cells - if they do it will break. But it gets you started
I'm having trouble debugging Error 450 in my code. With 17 ranges, the code is running fine, but when more ranges are added, it shows Error 450 Wrong number of arguments or invalid property assignment. Please have a look at the code. The first line is highlighted and 'Union' also when the error is displayed.
Sub Set_PrintArea()
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
Dim rng6 As Range
Dim rng7 As Range
Dim rng8 As Range
Dim rng9 As Range
Dim rng10 As Range
Dim rng11 As Range
Dim rng12 As Range
Dim rng13 As Range
Dim rng14 As Range
Dim rng15 As Range
Dim rng16 As Range
Dim rng17 As Range
Dim rng18 As Range
Dim rng19 As Range
Dim rng20 As Range
Dim rng21 As Range
Dim rng22 As Range
Dim rng23 As Range
Dim rng24 As Range
Dim rng25 As Range
Dim rng26 As Range
Dim rng27 As Range
Dim rng28 As Range
Dim rng29 As Range
Dim rng30 As Range
Dim rng31 As Range
Dim rng32 As Range
Dim rng33 As Range
Dim rng34 As Range
Dim rng35 As Range
With Sheets("Performance")
Set rng1 = .Range("$A$1:$U$13")
Set rng2 = .Range("$B$15:$Z$52")
Set rng3 = .Range("$B$55:$Z$92")
Set rng4 = .Range("$B$95:$Z$132")
Set rng5 = .Range("$B$135:$Z$172")
Set rng6 = .Range("$B$175:$Z$212")
Set rng7 = .Range("$B$215:$Z$252")
Set rng8 = .Range("$B$255:$Z$292")
Set rng9 = .Range("$B$295:$Z$332")
Set rng10 = .Range("$B$335:$Z$372")
Set rng11 = .Range("$B$374:$Z$407")
Set rng12 = .Range("$B$410:$Z$443")
Set rng13 = .Range("$B$446:$Z$479")
Set rng14 = .Range("$B$482:$Z$515")
Set rng15 = .Range("$B$518:$Z$551")
Set rng16 = .Range("$B$554:$Z$587")
Set rng17 = .Range("$B$590:$S$610")
Set rng18 = .Range("$B$613:$V$642")
Set rng19 = .Range("$B$650:$U$662")
Set rng20 = .Range("$B$664:$Z$701")
Set rng21 = .Range("$B$704:$Z$741")
Set rng22 = .Range("$B$744:$Z$781")
Set rng23 = .Range("$B$784:$Z$821")
Set rng24 = .Range("$B$824:$Z$861")
Set rng25 = .Range("$B$864:$Z$901")
Set rng26 = .Range("$B$904:$Z$941")
Set rng27 = .Range("$B$944:$Z$981")
Set rng28 = .Range("$B$984:$Z$1021")
Set rng29 = .Range("$B$1023:$AD$1066")
Set rng30 = .Range("$B$1069:$AD$1112")
Set rng31 = .Range("$B$1115:$AD$1158")
Set rng32 = .Range("$B$1161:$AD$1204")
Set rng33 = .Range("$B$1207:$AD$1250")
Set rng34 = .Range("$B$1253:$AD$1296")
Set rng35 = .Range("$B$1299:$S$1323")
With .PageSetup
.PrintArea = Union(rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8, rng9, rng10, rng11, rng12, rng13, rng14, rng15, rng16, rng17, rng18, rng19, rng20, rng21, rng22, rng23, rng24, rng25, rng26, rng27, rng28, rng29, rng30, rng31, rng32, rng33, rng34, rng35).Address
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
.PrintPreview
End With
End Sub
Thanks in advance.
According to msdn, http://msdn.microsoft.com/en-us/library/office/ff834621(v=office.14).aspx
Union can only accept 30 parameters
Syntax
expression .Union(Arg1, Arg2, Arg3, Arg4, Arg5, Arg6, Arg7, Arg8, Arg9, Arg10, Arg11, Arg12, Arg13, Arg14, Arg15, Arg16, Arg17, Arg18, Arg19, Arg20, Arg21, Arg22, Arg23, Arg24, Arg25, Arg26, Arg27, Arg28, Arg29, Arg30)
To overcome this, you can split that 35 ranges into 2 sets.
e.g.
union1 = union(rng1, rng2, ... , rng30)
union2 = union(rng31, rng32, ... , rng35)
unionFinal = union(union1, union2)
You have hit two limits in Excel: maximum parameters for Union (as others have said) and the string length limit for PrintArea of 255 characters.
Your print area address is < 255 long if you don't use absolute addressing
Try this
Sub Demo()
ReDim rng(1 To 35)
Dim rngPrintArea As Range
Dim i As Long
With Sheets("Performance")
Set rng(1) = .Range("$A$1:$U$13")
Set rng(2) = .Range("$B$15:$Z$52")
Set rng(3) = .Range("$B$55:$Z$92")
Set rng(4) = .Range("$B$95:$Z$132")
Set rng(5) = .Range("$B$135:$Z$172")
Set rng(6) = .Range("$B$175:$Z$212")
Set rng(7) = .Range("$B$215:$Z$252")
Set rng(8) = .Range("$B$255:$Z$292")
Set rng(9) = .Range("$B$295:$Z$332")
Set rng(10) = .Range("$B$335:$Z$372")
Set rng(11) = .Range("$B$374:$Z$407")
Set rng(12) = .Range("$B$410:$Z$443")
Set rng(13) = .Range("$B$446:$Z$479")
Set rng(14) = .Range("$B$482:$Z$515")
Set rng(15) = .Range("$B$518:$Z$551")
Set rng(16) = .Range("$B$554:$Z$587")
Set rng(17) = .Range("$B$590:$S$610")
Set rng(18) = .Range("$B$613:$V$642")
Set rng(19) = .Range("$B$650:$U$662")
Set rng(20) = .Range("$B$664:$Z$701")
Set rng(21) = .Range("$B$701:$Z$741")
Set rng(22) = .Range("$B$744:$Z$781")
Set rng(23) = .Range("$B$784:$Z$821")
Set rng(24) = .Range("$B$824:$Z$861")
Set rng(25) = .Range("$B$864:$Z$901")
Set rng(26) = .Range("$B$904:$Z$941")
Set rng(27) = .Range("$B$944:$Z$981")
Set rng(28) = .Range("$B$984:$Z$1021")
Set rng(29) = .Range("$B$1023:$AD$1066")
Set rng(30) = .Range("$B$1069:$AD$1112")
Set rng(31) = .Range("$B$1115:$AD$1158")
Set rng(32) = .Range("$B$1161:$AD$1204")
Set rng(33) = .Range("$B$1207:$AD$1250")
Set rng(34) = .Range("$B$1253:$AD$1296")
Set rng(35) = .Range("$B$1299:$S$1323")
Set rngPrintArea = rng(1)
For i = 2 To 35
Set rngPrintArea = Union(rngPrintArea, rng(i))
Next
With .PageSetup
.PrintArea = rngPrintArea.Address(False, False)
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End With
End Sub
Shorter...
Sub Set_PrintArea()
Dim rng As Range, x As Long, arr
'add all your ranges here...
arr = Array("$A$1:$U$13", "$B$15:$Z$52", "$B$55:$Z$92", "$B$95:$Z$132")
With Worksheets("Performance")
Set rng = .Range(arr(LBound(arr)))
For x = LBound(arr) + 1 To UBound(arr)
Set rng = Application.Union(rng, .Range(arr(x)))
Next x
With .PageSetup
.PrintArea = rng.Address
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
.PrintPreview
End With
End Sub
I have a VBScript which creates a table. It loops through an array and inserts the information into a table in a Word document.
'Create new word doc
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "12"
objSelection.TypeText sFileSelected
objSelection.TypeParagraph()
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "12"
Set objRange = objSelection.Range
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.opentextfile(logPathAndFileName)
strAll = objTF.readall
arrVar = Split(strAll, vbNewLine)
numcols = 3
objDoc.Tables.Add objRange, UBound(arrVar) - LBound(arrVar) + 1, numcols
Set objTable = objDoc.Tables(1)
For lngrow = LBound(arrVar) To UBound(arrVar)
If lngrow > 0 Then
arrVar2 = Split(arrVar(lngrow), vbTab)
For lngcol = LBound(arrVar2) To UBound(arrVar2)
objTable.Cell(lngrow, lngcol + 1).Range.Text = arrVar2(lngcol)
If lngrow = 1 Then
Set myRange = objDoc.Range(objTable.Cell(2, 1).Range.Start,objTable.Cell(4, 1).Range.End)
myRange.Merge
End If
Next
End If
Next
This produces a table like this:
What I would like to do now is merge the top row: DATABASE MODIFICATIONS. How can I merge the row?
Try this code for merging whole row (first row in this sample line):
objTable.Rows(1).Cells.Merge
Edit: if you need to merge some cells in the row you could do it in this way (by selection first and last cells- area in between will be merged):
'for 2nd row, cells from 2 to 3
objTable.Cell(2, 2).Merge objTable.Cell(2, 3)