I am trying to use VBA to create a Word document with multiple tables each on a new page (using a loop) compiled with cell information from Excel.
So far everything works fantastically except after inserting the first table it is replaced by the second table, then the third table replaces the second, and so on. What I am left with is only the last created table.
I'm not sure how to cause a new table to be created instead of replacing the previously created table.
Screen shot of Excel table
Sub Export_to_Word()
'(1) Word objects.
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdCell As Word.Cell
Dim wdTabl As Word.Table
Dim wdRange As Word.Range
'(2) Excel objects
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim strValue As String
Dim i As Integer
Dim x As Integer
'For assiging integer value to calculate number of table rows
Dim ARows As Integer
Dim BRows As Integer
Dim CRows As Integer
Dim DRows As Integer
'For copying question part as a value in the excel sheet
Dim QueNum As Variant
Dim PartA As Variant
Dim PartB As Variant
Dim PartC As Variant
Dim PartD As Variant
'For copying the question in the excel sheet
Dim QueA As Variant
Dim QueB As Variant
Dim QueC As Variant
Dim QueD As Variant
'For copying question part as a value in the excel sheet
Dim MarkA As Variant
Dim MarkB As Variant
Dim MarkC As Variant
Dim MarkD As Variant
'For copying the answers in the excel sheet
Dim AnsA As Variant
Dim AnsB As Variant
Dim AnsC As Variant
Dim AnsD As Variant
'For copying the header values in the excel sheet
Dim CandCode As Variant
Dim AnPath As Variant
Dim Logo As Variant
Dim EngNam As Variant
Dim EngTex As Variant
Dim FreNam As Variant
Dim FreTex As Variant
'(4) Initialize the Excel objects
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
'(5)Create table in excel before copying to word
'Create Word file.
Set wdApp = New Word.Application
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
'(5a)Enter excel values into header
With wdDoc.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = CandCode & vbCr & vbCr & AnPath
.Headers(wdHeaderFooterPrimary).Range.Font.Name = "Arial"
.Headers(wdHeaderFooterPrimary).Range.Font.Size = 7
.Headers(wdHeaderFooterPrimary).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
'(5b)Start of new cycle for loop
For i = 4 To 6
'(5c) Equate cell values to the the variables defined under Excel objects (Part 2). N.B in equation "Cells(3,i) 3= row number and i=column number
ARows = wsSheet.Cells(3, i).Value
BRows = wsSheet.Cells(7, i).Value
CRows = wsSheet.Cells(11, i).Value
DRows = wsSheet.Cells(15, i).Value
QueNum = wsSheet.Cells(1, i).Value
PartA = wsSheet.Range("A2").Value
PartB = wsSheet.Range("A6").Value
PartC = wsSheet.Range("A10").Value
PartD = wsSheet.Range("A14").Value
QueA = wsSheet.Cells(2, i).Value
QueB = wsSheet.Cells(6, i).Value
QueC = wsSheet.Cells(10, i).Value
QueD = wsSheet.Cells(14, i).Value
MarkA = wsSheet.Cells(4, i).Value
MarkB = wsSheet.Cells(8, i).Value
MarkC = wsSheet.Cells(12, i).Value
MarkD = wsSheet.Cells(16, i).Value
AnsA = wsSheet.Cells(5, i).Value
AnsB = wsSheet.Cells(9, i).Value
AnsC = wsSheet.Cells(13, i).Value
AnsD = wsSheet.Cells(17, i).Value
CandCode = wsSheet.Range("V24").Value
AnPath = wsSheet.Range("V25").Value
Logo = wsSheet.Range("V26").Value
EngNam = wsSheet.Range("V27").Value
EngTex = wsSheet.Range("V28").Value
FreNam = wsSheet.Range("V29").Value
FreTex = wsSheet.Range("V30").Value
'(5d)Creates variables that identifes location of each of the rows with the question part
TotRows = ARows + BRows + CRows + DRows + 5
QuesA_row = 2
QuesB_row = ARows + 3
QuesC_row = ARows + BRows + 4
QuesD_row = ARows + BRows + CRows + 5
'(5e)Create Word table
Set wdRange = wdDoc.Range
wdDoc.Tables.Add wdRange, NumRows:=(TotRows), NumColumns:=5, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow
Set wdTabl = wdDoc.Tables(1)
'(5f)Edit Table
With wdTabl
.ApplyStyleHeadingRows = False
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = False
.ApplyStyleLastColumn = True
.ApplyStyleRowBands = False
.ApplyStyleColumnBands = False
'Changes font of table
.Range.Font.Name = "Arial"
.Range.Font.Size = "10"
'Changes spacing of lines in table to single
.Range.ParagraphFormat.SpaceBeforeAuto = False
.Range.ParagraphFormat.SpaceBefore = 8
.Range.ParagraphFormat.SpaceAfterAuto = False
.Range.ParagraphFormat.SpaceAfter = 0
.Range.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
.Range.ParagraphFormat.PageBreakBefore = False
'Adjust column widths
.Columns(1).SetWidth ColumnWidth:=20, RulerStyle:=wdAdjustNone
.Columns(2).SetWidth ColumnWidth:=23, RulerStyle:=wdAdjustNone
.Columns(3).SetWidth ColumnWidth:=400, RulerStyle:=wdAdjustNone
.Columns(4).SetWidth ColumnWidth:=11, RulerStyle:=wdAdjustNone
.Columns(5).SetWidth ColumnWidth:=40, RulerStyle:=wdAdjustNone
'Shading for marks column & borders
.Borders.Enable = False
.Columns(5).Shading.BackgroundPatternColor = wdColorGray20
.Columns(5).Borders(wdBorderTop).Color = wdColorBlack
.Columns(5).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Borders(wdBorderLeft).Color = wdColorBlack
.Columns(5).Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Borders(wdBorderLeft).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Borders(wdBorderRight).Color = wdColorBlack
.Columns(5).Borders(wdBorderRight).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Borders(wdBorderRight).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Borders(wdBorderBottom).Color = wdColorBlack
.Columns(5).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Cells(1).Borders(wdBorderBottom).Color = wdColorBlack
.Columns(5).Cells(1).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Cells(1).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
'Underlines for questions
.Columns(3).Cells.Borders.InsideLineStyle = wdLineStyleSingle 'Adds bottom border to all cells in column 3
.Columns(3).Cells(1).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(1).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(1).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(QuesA_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(QuesA_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(QuesA_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(QuesB_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(QuesB_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(QuesB_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(QuesC_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(QuesC_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(QuesC_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(QuesD_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(QuesD_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(QuesD_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(TotRows).Borders(wdBorderBottom).Color = wdColorBlack 'Adds border to bottom row of column
.Columns(3).Cells(TotRows).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(TotRows).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
'Enter Data into table
.Columns(1).Cells(2).Range.Text = QueNum & "."
.Columns(2).Cells(QuesA_row).Range.Text = PartA
.Columns(2).Cells(QuesB_row).Range.Text = PartB
.Columns(2).Cells(QuesC_row).Range.Text = PartC
.Columns(2).Cells(QuesD_row).Range.Text = PartD
.Columns(3).Cells(QuesA_row).Range.Text = QueA
.Columns(3).Cells(QuesB_row).Range.Text = QueB
.Columns(3).Cells(QuesC_row).Range.Text = QueC
.Columns(3).Cells(QuesD_row).Range.Text = QueD
.Columns(5).Cells(1).Range.Text = "Marks"
.Columns(5).Cells(QuesA_row).Range.Text = MarkA
.Columns(5).Cells(QuesB_row).Range.Text = MarkB
.Columns(5).Cells(QuesC_row).Range.Text = MarkC
.Columns(5).Cells(QuesD_row).Range.Text = MarkD
'Modifying marks column
.Columns(5).Cells(1).Range.Font.Bold = True 'Modifys "marks" cell
.Columns(5).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(1).Range.Cells.VerticalAlignment = wdCellAlignVerticalBottom
.Columns(5).Cells(QuesA_row).Range.Font.Bold = True
.Columns(5).Cells(QuesA_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(QuesA_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
.Columns(5).Cells(QuesB_row).Range.Font.Bold = True
.Columns(5).Cells(QuesB_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(QuesB_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
.Columns(5).Borders(wdBorderTop).Color = wdColorBlack
.Columns(5).Cells(QuesB_row).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Cells(QuesB_row).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Cells(QuesC_row).Range.Font.Bold = True
.Columns(5).Cells(QuesC_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(QuesC_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
.Columns(5).Borders(wdBorderTop).Color = wdColorBlack
.Columns(5).Cells(QuesC_row).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Cells(QuesC_row).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Cells(QuesD_row).Range.Font.Bold = True
.Columns(5).Cells(QuesD_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(QuesD_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
.Columns(5).Borders(wdBorderTop).Color = wdColorBlack
.Columns(5).Cells(QuesD_row).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Cells(QuesD_row).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
'Adjusts text alignment in question column
.Columns(3).Cells.VerticalAlignment = wdCellAlignVerticalBottom
' Exit table and insert page break so next table starts at beginning of page
With wdRange
.Collapse Direction:=wdCollapseEnd
.InsertParagraphAfter
.InsertBreak Type:=wdPageBreak
.Collapse Direction:=wdCollapseEnd
End With
End With
Next i
'(7)Identifies all numbered words and replaces them with all caps bold
Dim A(10) As String
A(1) = "one"
A(2) = "two"
A(3) = "three"
A(4) = "four"
A(5) = "five"
A(6) = "six"
A(7) = "seven"
A(8) = "eight"
A(9) = "nine"
A(10) = "ten"
Set wdRange = ActiveDocument.Content
With wdRange
For x = 1 To 10
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
.Find.Replacement.Font.Bold = True
With .Find
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Replacement.Font.Bold = True
.Replacement.Font.Allcaps = True
wdRange.Find.Execute FindText:=A(x), ReplaceWith:=A(x), Format:=True, _
Replace:=wdReplaceAll
End With
Next x
End With
'(8)Null out the variables.
Set wdCell = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
Set wdRange = Nothing
Set wdTabl = Nothing
'(9) Adds message box to show complete
MsgBox "Success! The exam questions are complete!", vbInformation
End Sub
This stripped-down version worked for me:
Sub Export_to_Word()
Dim wdApp As Word.Application, i As Long, wdDoc As Word.Document
Dim wdCell As Word.Cell, wdTabl As Word.Table, wdRange As Word.Range
Dim wbBook As Workbook, wsSheet As Worksheet
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
Set wdApp = New Word.Application
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
For i = 1 To 5
wdDoc.Paragraphs.Add
Set wdRange = ActiveDocument.Paragraphs.Last.Range
Set wdTabl = wdDoc.Tables.Add(wdRange, NumRows:=5, NumColumns:=5, _
DefaultTableBehavior:=wdWord8TableBehavior, _
AutoFitBehavior:=wdAutoFitWindow)
With wdTabl
.Borders.Enable = True
.Columns(1).Cells(1).Range.Text = "First"
.Columns(5).Cells(5).Range.Text = "Last"
End With
Next i
End Sub
You set up only one table.
'(5e)Create Word table
Set wdRange = wdDoc.Range
wdDoc.Tables.Add wdRange, NumRows:=(TotRows), NumColumns:=5, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow
Set wdTabl = wdDoc.Tables(1)
Change code.
'(5e)Create Word table
Set wdRange = wdDoc.Range
Set wdTabl = wdDoc.Tables.Add(wdRange, NumRows:=(TotRows), NumColumns:=5, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow)
'Set wdTabl = wdDoc.Tables(1)
Related
I am quite new to vba and I need to write a script that has as input a document with some revisions. For each paragraph i would like to have in a table the original text (no revisions) and the final text (as if all revisions have been accepted). If this is to difficult I would like to at least have a table that contains the new text, the number of the paragraph in the original document and the number of the paragraph in the final version
Here an example of how could look like the input of the script
Here what i would like to have as output
Here what I have been able to do. I am not able to get the original text and in case of multiple phrases insertion the script is able to recognize only the first one as new line.
The script go through all the paragraph, if the paragraph contains no revision just the text is added in the table. If the text contains at list one revision all except the last revision are accepted and if the last the revision is an insert then if the paragraph text before and after all revisions have been accepted is the same the next paragraph is considered as new line. If the last revision is a delete then if the paragraph text before all revisions have been accepted is equal to the text of reviosion the text paragraph is considered as interely deleted.
Sub TrackchangesTable()
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim oRow As Row
Dim oCol As Column
Dim oRange As Range
Dim oRevision As Revision
Dim strText As String
Dim Title As String
Dim Para As Paragraph
Dim NewLine As Boolean
Dim DraftText As String
Dim NewId As Long
Dim OldId As Long
Dim OldText As String
Dim Stile As String
Dim OriginalDoc As Document
Set oDoc = ActiveDocument
If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.", vbOKOnly, Title
GoTo ExitHere
Else
If MsgBox("Do you want to extract tracked changes to a new document?" & vbCr & vbCr & , _
vbYesNo + vbQuestion) <> vbYes Then
GoTo ExitHere
End If
End If
Application.ScreenUpdating = False
Set oNewDoc = Documents.Add
oNewDoc.PageSetup.Orientation = wdOrientLandscape
With oNewDoc
.Content = ""
With .PageSetup
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
.TopMargin = CentimetersToPoints(2.5)
End With
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=7)
End With
With oNewDoc.Styles(wdStyleNormal)
With .Font
.Name = "Arial"
.Size = 9
.Bold = False
End With
With .ParagraphFormat
.LeftIndent = 0
End With
End With
With oTable
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
For Each oCol In .Columns
oCol.PreferredWidthType = wdPreferredWidthPercent
Next oCol
.Columns(1).PreferredWidth = 5 'Page
.Columns(2).PreferredWidth = 5 'Note
.Columns(3).PreferredWidth = 10 'Final Text
.Columns(4).PreferredWidth = 15 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Old Id
.Columns(6).PreferredWidth = 10 'New ID
.Columns(7).PreferredWidth = 10 'Stile
End With
With oTable.Rows(1)
.Cells(1).Range.Text = "Page"
.Cells(2).Range.Text = "Note"
.Cells(3).Range.Text = "Final Text"
.Cells(4).Range.Text = "Deleted Text"
.Cells(5).Range.Text = "Old Id"
.Cells(6).Range.Text = "New Id"
.Cells(7).Range.Text = "stile"
End With
NewLine = False
OldId = 1
NewId = 1
For Each Para In ThisDocument.Paragraphs
Stile = Para.Range.Style
If Para.Range.Revisions.Count = 0 And NewLine = False Then
StrTextFinale = Para.Range.Text
ElseIf Para.Range.Revisions.Count = 0 And NewLine = True Then
StrTextFinale = Para.Range.Text
Note = "New Line"
NewLine = False
OldId = OldId - 1
ElseIf Para.Range.Revisions.Count > 0 Then
For i = 1 To Para.Range.Revisions.Count
If i < Para.Range.Revisions.Count Then
Para.Range.Revisions(i).Accept
Else
If Para.Range.Revisions(i).Type = wdRevisionInsert Then
DraftText = Para.Range.Text
Para.Range.Revisions(i).Accept
StrTextFinale = Para.Range.Text
If DraftText = StrTextFinale Then
NewLine = True
End If
ElseIf Para.Range.Revisions(i).Type = wdRevisionDelete Then
DraftText = Para.Range.Revisions(i).Range.Text
StrTextFinale = Para.Range.Text
If DraftText = StrTextFinale Then
Note = "Testo eliminato"
StrTextFinale = "volutamente cancellato"
OldText = Para.Range.Text
NewId = NewId - 1
Else
Para.Range.Revisions(i).Accept
StrTextFinale = Para.Range.Text
End If
End If
End If
Next
End If
Set oRow = oTable.Rows.Add
With oRow
.Cells(1).Range.Text = Para.Range.Information(wdActiveEndAdjustedPageNumber)
.Cells(2).Range.Text = Note
.Cells(3).Range.Text = StrTextFinale
.Cells(4).Range.Text = OldText
.Cells(5).Range.Text = OldId
.Cells(6).Range.Text = NewId
.Cells(7).Range.Text = Stile
Note = ""
End With
OldId = OldId + 1
NewId = NewId + 1
OldText = ""
Next
With oTable.Rows(1)
.Range.Font.Bold = True
.HeadingFormat = True
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox ("Over")
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing
End Sub
Can somebody help me to improve this script?
I am trying to write a macro to insert a custom watermark in my Word document.
The code works perfectly for the first two pages of the document but thereafter the the Textbox does not rotate to -45 as mentioned in the code
What am I doing wrong?
Sub CustomWatermark()
Dim activeDoc As Document
Dim rngDoc As Range
Dim shpTextBox As Shape
Dim lngPages As Long
Dim i As Long
Dim strWatermark As String
Set activeDoc = ActiveDocument
lngPages = activeDoc.Range.Information(wdNumberOfPagesInDocument)
strWatermark = InputBox("Enter Watermark")
With activeDoc
For i = 1 To lngPages
Set rngDoc = .GoTo(What:=wdGoToPage, Name:=i)
rngDoc.Collapse wdCollapseStart
Set shpTextBox = .Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=InchesToPoints(1), _
Top:=InchesToPoints(4), _
Width:=InchesToPoints(6), _
Height:=InchesToPoints(2), _
Anchor:=rngDoc)
With shpTextBox
.Line.Visible = msoFalse
.Rotation = -45
.WrapFormat.Type = wdWrapBehind
.TextFrame.HorizontalAnchor = msoAnchorCenter
.TextFrame.VerticalAnchor = msoAnchorMiddle
With .TextFrame.TextRange
.Font.AllCaps = True
.Font.Size = "60"
.Font.ColorIndex = wdGray25
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Text = strWatermark
End With
End With
Next
End With
End Sub
It looks that, selecting all their range and doing rotation at once, works...
Sub CustomWatermarkBis()
Dim activeDoc As Document, rngDoc As Range, shpTextBox As Shape
Dim lngPages As Long, i As Long, strWatermark As String, shR As ShapeRange
Dim arrRot As Variant, k As Long
Set activeDoc = ActiveDocument
lngPages = activeDoc.Range.Information(wdNumberOfPagesInDocument)
ReDim arrRot(0 To lngPages - 1)
strWatermark = InputBox("Enter Watermark Text")
With activeDoc
For i = 1 To lngPages
Set rngDoc = .GoTo(What:=wdGoToPage, Name:=i)
rngDoc.Collapse wdCollapseStart
Set shpTextBox = .Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=InchesToPoints(1), _
Top:=InchesToPoints(4), _
Width:=InchesToPoints(6), _
Height:=InchesToPoints(2), _
Anchor:=rngDoc)
With shpTextBox.TextFrame.TextRange
.Font.AllCaps = True
.Font.Size = "60"
.Font.ColorIndex = wdGray25
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Text = strWatermark
End With
shpTextBox.Name = "T" & i
arrRot(k) = shpTextBox.Name: k = k + 1
Next
Set shR = .Shapes.Range(arrRot)
End With
With shR
.Select
.Line.Visible = msoFalse
.Rotation = -45
.WrapFormat.Type = wdWrapBehind
.TextFrame.HorizontalAnchor = msoAnchorCenter
.TextFrame.VerticalAnchor = msoAnchorMiddle
End With
Selection.Collapse
End Sub
Re-ordering your code to add the text before changing the rotation should solve the issue. It certainly does for me in Word 365.
EDIT: That approach worked for me exactly twice and now I can't repeat it. Adding the text box to the header does work reliably though, and results in a much tidier document.
Sub CustomWatermarkInHeader()
Dim activeDoc As Document
Dim rngDoc As Range
Dim strWatermark As String
Dim docSection As Section
Dim shpTextBox As Shape
Set activeDoc = ActiveDocument
strWatermark = InputBox("Enter Watermark")
With activeDoc
For Each docSection In .Sections
Set rngDoc = docSection.Headers(wdHeaderFooterPrimary).Range
rngDoc.Collapse wdCollapseStart
Set shpTextBox = .Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=InchesToPoints(1), _
Top:=InchesToPoints(4), _
Width:=InchesToPoints(6), _
Height:=InchesToPoints(2), _
Anchor:=rngDoc)
With shpTextBox
With .TextFrame
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
With .TextRange
.Font.AllCaps = True
.Font.Size = "60"
.Font.ColorIndex = wdGray25
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Text = strWatermark
End With
End With
.Line.Visible = msoFalse
.Rotation = -45
.WrapFormat.Type = wdWrapBehind
End With
Next
End With
End Sub
However, you may want to consider:
adding the text box to the header instead of cluttering your document with a text box on every page. You will achieve the same result with fewer text boxes.
Using the built-in functionality to add a custom watermark. You can find this on the Design tab of the ribbon.
Instead of:
.Rotation = -45
Try:
.ThreeD.IncrementRotationZ -45
https://learn.microsoft.com/en-us/office/vba/api/word.threedformat
I have a form in ms word with some of the fields are content control and some (which are the radio buttons) are ActiveX control. I want to automatically transfer hundred word forms to an excel file. I use the following vba code:
Sub getWordFormData()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim CCtl As Word.ContentControl
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
Application.ScreenUpdating = False
If myFolder = "" Then Exit Sub
Set myWkSht = ActiveSheet
ActiveSheet.Cells.Clear
Range("A1") = "name"
Range("a1").Font.Bold = True
Range("B1") = "age"
Range("B1").Font.Bold = True
Range("C1") = "gender"
Range("C1").Font.Bold = True
Range("D1") = "checkbox1"
Range("D1").Font.Bold = True
Range("E1") = "checkbox2"
Range("E1").Font.Bold = True
Range("F1") = "singlechoice1"
Range("F1").Font.Bold = True
Range("G1") = "singlechoice2"
Range("G1").Font.Bold = True
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(myFolder & "\*.docx", vbNormal)
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With myDoc
j = 0
For Each CCtl In .ContentControls
j = j + 1
myWkSht.Cells(i, j) = CCtl.Range.Text
Next
myWkSht.Columns.AutoFit
End With
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True
End Sub
all the data (text fields, checkbox) are transferred successfully but, the radio button (which is ActiveX) is not transferred.
This is the word doc:
This is the excel result:
How can I solve this problem?
You can refer to an ActiveX control on a Word document by it's name
myDoc.singlechoice1.Value
It is better to refer to the ContentControls by their tag names.
myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
Refactored Code
Sub getWordFormData()
Dim wdApp As Object, myDoc As Object
Dim myFolder As String, strFile As String
Dim i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
If Len(Dir(myFolder)) = 0 Then
MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
Exit Sub
End If
Application.ScreenUpdating = False
Set wdApp = CreateObject("Word.Application")
With ActiveSheet
.Cells.Clear
With .Range("A1:G1")
.Value = Array("name", "age", "gender", "checkbox1", "checkbox2", "singlechoice1", "singlechoice2")
.Font.Bold = True
End With
strFile = Dir(myFolder & "\*.docx", vbNormal)
i = 1
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
.Cells(i, 1).Value = myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
.Cells(i, 2).Value = myDoc.SelectContentControlsByTag("age").Item(1).Range.Text
.Cells(i, 3).Value = myDoc.SelectContentControlsByTag("gender").Item(1).Range.Text
.Cells(i, 4).Value = myDoc.SelectContentControlsByTag("checkbox1").Item(1).Checked
.Cells(i, 5).Value = myDoc.SelectContentControlsByTag("checkbox2").Item(1).Checked
.Cells(i, 6).Value = myDoc.singlechoice1.Value
.Cells(i, 7).Value = myDoc.singlechoice2.Value
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Application.ScreenUpdating = True
End With
End Sub
Your radiobuttons are inlineshapes so you need a separate loop for them
to keep in line with your current code, it would be something like
Dim shp As InlineShape
For Each shp In .InlineShapes
j = j + 1
myWkSht.Cells(i, j) = shp.OLEFormat.Object.Value
Next shp
However I wouldn't want to rely on Word always giving me the right order and there could be other inlineshapes so it might be better to check the controls first:
With myDoc
'content controls
For Each CCtl In .ContentControls
Select Case CCtl.Title
Case "name"
myWkSht.Cells(i, 1) = CCtl.Range.Text
'similar for age and gender
Case "checkbox1"
myWkSht.Cells(i, 4) = CCtl.Checked 'true and false are easier to evaluate in Excel than the checkmark symbols
'same for checkbox 2
End Select
Next CCtl
'option buttons
For Each shp In .InlineShapes
If shp.Type = wdInlineShapeOLEControlObject Then 'skip other inlineshapes
Select Case shp.OLEFormat.Object.Name
Case "singleSelectQuestionOption1" 'name it something unique
myWkSht.Cells(i, 6) = shp.OLEFormat.Object.Value
'similar for option button 2
End Select
End If
Next shp
End With
I'm trying to create word document from content in Excel.
When I tryto add header/footer in the word, I'm getting an error "Run Time Error 5941 : The requested member of the collection does not exist" on line .Headers(wdHeaderFooterPrimary).Range.Text = "Header text". Please suggest how I can work with this?
Sub CreateFAQWord()
Dim myRow As Long
Dim objWord As Object
Dim objDoc As Object
Dim question As String
Dim answer As String
Dim rng As Range
Dim i As Long
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add()
objWord.Selection.Style = objDoc.Styles("Title")
objWord.Selection.Paragraphs.Alignment = 1
objWord.Selection.TypeText Text:="Title"
objWord.Selection.TypeParagraph
objWord.Selection.TypeParagraph
With objDoc
.Styles.Add ("BoldNormal")
With .Styles("BoldNormal").Font
.Name = "Calibri"
.Size = 11
.Bold = True
.Italic = True
.Underline = False
End With
End With
myRow = 2
' Value 2 here is the column in which questions are present. Change accordingly
While Cells(myRow, 2).Value <> ""
' Value 9 here is the column in which Yes/No is present. Change accordingly
If Cells(myRow, 9) = "Yes" Then
objDoc.Activate
question = Cells(myRow, 2)
answer = Cells(myRow, 3)
objWord.Selection.Style = objDoc.Styles("BoldNormal")
objWord.Selection.TypeText Text:=question
objWord.Selection.TypeParagraph
objWord.Selection.Style = objDoc.Styles("Normal")
objWord.Selection.TypeText Text:=answer
objWord.Selection.TypeParagraph
objWord.Selection.TypeParagraph
End If
myRow = myRow + 1
Wend
For i = 1 To objDoc.Sections.Count
With objDoc.Sections(i)
.Headers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Text = "Header text"
.Footers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Text = "Footer text"
End With
Next
' Change the location path of where you want the document to be saved as needed
objDoc.SaveAs "C:\Users\2021282\Desktop\FAQ"
End Sub
I do not think you can use .Range.Text
Instead try to assign a reference to a range object. To make this work you need to add the "Microsoft Word XX.X Object Library" under references.
Dim objRange as Word.Range
For i = 1 To objDoc.Sections.Count
With objDoc.Sections(i)
Set objRange = .Headers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range
objRange = "Header Text"
Set objRange = Nothing
Set objRange = .Footers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range
objRange = "Footer text"
Set objRange = Nothing
End With
Next
In one excel instance (Instance A), my workbook (Workbook A) performs calculations based on user inputs and creates a worksheet with a chart object. This worksheet is copied and pasted into another workbook (Workbook B), which is closed in Instance A and then opened in a second excel instance (Instance B). Workbook B/Instance B are kept open and in a separate window, as the function of Workbook A/Instance A is to create worksheets to be viewed in Workbook B/Instance B.
So the macro process is: Worksheet is created in Instance A/Workbook A -> Workbook B is closed in Instance B -> Workbook B is opened in Instance A -> worksheet is copied from Workbook A to Workbook B -> Workbook B is saved/closed in Instance A -> Workbook B is opened in Instance B
In the interest of full disclosure, this is the entire sub:
Sub CopySSToNewWorkbook()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim MoveFromWkb As Workbook
Dim MoveFromSht As Worksheet
Dim ChartName As String
Dim RngToCover As Range
Dim duplicateChtPic As Shape
Dim NewSheetName As String
Dim TagString As String
If InputPage.Range("PanelTag") <> "" Then TagString = "-" & InputPage.Range("PanelTag").Text
Set MoveFromWkb = ThisWorkbook
'Set MoveFromSht = MoveFromWkb.Sheets("InputPage")
If InputPage.Range("PgNum") <> "" Then
NewSheetName = InputPage.Range("RoomNum").Text & TagString & " (Pg" & InputPage.Range("PgNum") & ")"
Set MoveFromSht = MoveFromWkb.Worksheets(NewSheetName)
Else
NewSheetName = InputPage.Range("RoomNum").Text & TagString
Set MoveFromSht = MoveFromWkb.Worksheets(NewSheetName)
End If
Set RngToCover = MoveFromSht.Range("E19:Y34")
ChartName = "Panel" & InputPage.Range("PgNum")
'Duplicate method
Set duplicateChtPic = MoveFromSht.ChartObjects(ChartName).Duplicate()
MoveFromSht.Shapes(ChartName).Delete
duplicateChtPic.ZOrder msoSendToBack
duplicateChtPic.Select
Call DelinkChartFromData
With duplicateChtPic
.height = RngToCover.height ' resize
.Width = RngToCover.Width ' resize
.top = RngToCover.top - 2 ' reposition
.Left = RngToCover.Left - 6 ' reposition
End With
MoveFromSht.Shapes("SaveSpoolSheetButton").Delete
MoveFromSht.Shapes("EditSpoolSheetButton").Visible = msoTrue
MoveFromSht.Shapes("UpdatePageNumberButton").Visible = msoTrue
MoveFromSht.Shapes("DeletePanelButton").Visible = msoTrue
Dim CNumber As String
Dim RelNum As String
Dim CrtNum As String
Dim Percentage As String
Dim SSFolderName As String
Dim Wkbname As String
Dim FileLocation As String
Dim Sht As Worksheet
Dim SSCopyYesNo As Integer
Dim DoubleSheet As Boolean
Dim MoveToWkb As Workbook
Dim MoveToSht As Worksheet
Dim PasteSheet As Worksheet
Dim CellName As name
Dim SheetCounter As Integer
SheetCounter = 1
Dim i As Integer
Dim varLinks As Variant
With InputPage
CNumber = .Range("JNumber").Text
CrtNum = "Crt" & .Range("CrateNum").Text
RelNum = "Rel" & .Range("RelNum").Text
Percentage = (.Range("RelPct").value * 100) & "Pct"
End With
If CNumber <> "" Then
Wkbname = Wkbname & CNumber
End If
If RelNum <> "Rel" Then
Wkbname = Wkbname & "_" & RelNum
End If
If CrtNum <> "Crt" Then
Wkbname = Wkbname & "_" & CrtNum
End If
If Percentage <> "0Pct" Then
Wkbname = Wkbname & "_" & Percentage
End If
SSFolderName = CreateSSFolders
FileLocation = SSFolderName & "\" & Wkbname & ".xlsb"
Dim newXL As Excel.Application
'Set newXL = GetObject(FileLocation).Application
If IsFileOpen(FileLocation) = True Then
Set newXL = GetObject(FileLocation).Application
newXL.Application.ScreenUpdating = False
newXL.DisplayAlerts = False
newXL.Application.Workbooks(Wkbname & ".xlsb").Close SaveChanges:=False
' newXL.Application.Quit
' Set newXL = Nothing
Else
Set newXL = CreateObject("Excel.Application")
newXL.Visible = True
End If
If FileFolderExists(FileLocation) Then
' newXL.Application.ScreenUpdating = False
' newXL.Application.DisplayAlerts = False
' On Error Resume Next
' newXL.Workbooks(Wkbname & ".xlsb").Close SaveChanges:=False
' On Error GoTo 0
Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False
Set MoveToWkb = Workbooks(Wkbname & ".xlsb")
Else
Workbooks.Open (InputPage.MainFolderLocation.Text & "calc_and_trans\SpoolSheetWorkbookTemplate.xlsb")
Set MoveToWkb = Workbooks("SpoolSheetWorkbookTemplate.xlsb")
'if SSFolder doesn't already exist, the EditSpoolSheet module is imported to the new spoolsheet
'it is also exported to update any changes made
If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
MoveFromWkb.VBProject.VBComponents("EditSpoolSheet").export InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas" 'change path for home
MoveToWkb.VBProject.VBComponents.Import InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas" 'change path for home
Else
MoveFromSht.Shapes("EditSpoolSheetButton").Visible = msoFalse
MoveFromSht.Shapes("UpdatePageNumberButton").Visible = msoFalse
MoveFromSht.Shapes("CancelEditButton").Visible = msoFalse
MoveFromSht.Shapes("DeletePanelButton").Visible = msoFalse
End If
End If
For Each CellName In MoveToWkb.Names
If Right(CellName.name, 10) <> "Print_Area" Then
CellName.Delete
End If
Next
Dim NewPgNum As String
Dim OldPgNum As String
Dim startRead As Integer
Dim continueRun As Boolean
continueRun = False
NewPgNum = InputPage.Range("PgNum")
For Each Sht In MoveToWkb.Worksheets
startRead = InStr(Sht.name, "(Pg")
If Mid(Sht.name, startRead + 3) = (Right(MoveFromSht.name, Len(NewPgNum) + 1)) And DoubleSheet = False Then
DoubleSheet = True
Application.ScreenUpdating = True
SSCopyYesNo = MsgBox("Do you want to overwrite " & Sht.name & "?", vbYesNo + vbQuestion)
Application.ScreenUpdating = False
If SSCopyYesNo = vbYes Then
Dim spoolPosition As Integer
spoolPosition = Sht.Index
Sht.name = "_"
'attaching a macro to the edit spool sheet button
If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
MoveFromSht.Shapes("EditSpoolSheetButton").OnAction = "EditSpoolSheetClicked"
MoveFromSht.Shapes("UpdatePageNumberButton").OnAction = "UpdatePageNumberClicked"
MoveFromSht.Shapes("CancelEditButton").OnAction = "CancelEditButtonClicked"
MoveFromSht.Shapes("DeletePanelButton").OnAction = "DeletePanelButtonClicked"
End If
MoveFromSht.Range("Page_Number") = MoveFromSht.Range("AK21")
MoveFromSht.Copy After:=MoveToWkb.Sheets(spoolPosition)
Application.DisplayAlerts = False
Sht.Delete
Application.CutCopyMode = False
continueRun = True
End If
ElseIf DoubleSheet <> True Then
DoubleSheet = False
End If
SheetCounter = SheetCounter + 1
Next
If DoubleSheet = False Then
Set PasteSheet = Workbooks(MoveToWkb.name).Worksheets.Add
' MoveFromSht.Copy before:=MoveToWkb.Sheets(1)
'attaching a macro to the edit spool sheet button
If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
MoveFromSht.Shapes("EditSpoolSheetButton").OnAction = "EditSpoolSheetClicked"
MoveFromSht.Shapes("UpdatePageNumberButton").OnAction = "UpdatePageNumberClicked"
MoveFromSht.Shapes("CancelEditButton").OnAction = "CancelEditButtonClicked"
MoveFromSht.Shapes("DeletePanelButton").OnAction = "DeletePanelButtonClicked"
End If
MoveFromSht.Range("Page_Number") = MoveFromSht.Range("AK21")
MoveFromSht.Copy After:=MoveToWkb.Sheets(SheetCounter)
Application.CutCopyMode = False
continueRun = True
End If
If continueRun Then
For Each Sht In MoveToWkb.Worksheets
If Mid(Sht.name, 1, 5) = "Sheet" Then
Application.DisplayAlerts = False
Sht.Delete
End If
Next
Set MoveToSht = MoveToWkb.Sheets(MoveFromSht.name)
Dim moveToShtName As String
moveToShtName = MoveToSht.name
'fix in here
For Each CellName In MoveToWkb.Names
If Right(CellName.name, 10) <> "Print_Area" Then
Application.DisplayAlerts = False
CellName.Delete
End If
Next
Application.PrintCommunication = False
MoveToSht.DisplayPageBreaks = False
'For Each Sht In MoveToWkb.Worksheets
With MoveToSht.PageSetup
.PrintArea = "$A$1:$Z$36"
.Orientation = xlLandscape
.PaperSize = xlPaperLetter
.BlackAndWhite = True
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.LeftMargin = Application.InchesToPoints(1.6)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.CenterHorizontally = True
.CenterVertically = True
End With
Application.PrintCommunication = True
'%%%%%%%%new crate code %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'******************* Update Crate Sheet Info **************************************'
Dim crateSht As Worksheet
Dim frontSht As Worksheet
Set crateSht = MoveToWkb.Sheets("Crate_List")
Set frontSht = MoveToWkb.Sheets("FrontSheet")
Dim writeRow As Integer
Dim continueToEnd As Boolean
Dim roomColumn As Integer, pageColumn As Integer, sizeColumn As Integer, widthColumn As Integer, typeColumn As Integer, tagColumn As Integer
Dim infoTableCol As Integer
Dim colStep As Integer
For colStep = 1 To 15
Select Case crateSht.Cells(1, colStep).Text
Case "ROOM #"
roomColumn = colStep
Case "PAGE #"
pageColumn = colStep
Case "PANEL SIZE"
sizeColumn = colStep
Case "PANEL WIDTH"
widthColumn = colStep
Case "SQFT"
infoTableCol = colStep
Case "PANEL TYPE"
typeColumn = colStep
Case "PANEL TAG"
tagColumn = colStep
End Select
Next
'if first spoolsheet being added, set constant values (job name, job number etc.)
If MoveToWkb.Sheets.count = 3 Then
frontSht.Cells(5, 6) = MoveToSht.Range("AK2")
frontSht.Cells(6, 6) = MoveToSht.Range("AK3")
Dim EventsState As Boolean
EventsState = Application.EnableEvents
Application.EnableEvents = False
frontSht.Cells(6, 12) = MoveToSht.Range("AK7")
Application.EnableEvents = EventsState
End If
'determines where to write panel data: if row is blank, if Page # being written and read are both "" and panel tag/room # match, and if page numbers are not "" and match
For writeRow = 2 To 500
If Len(crateSht.Range("A" & writeRow).value) = 0 Or (InputPage.Range("PgNum") = "" And crateSht.Cells(writeRow, pageColumn).value = "" And crateSht.Range("A" & writeRow).value = InputPage.Range("RoomNum").value And _
crateSht.Cells(writeRow, tagColumn).value = InputPage.Range("PanelTag").value) Or (InputPage.Range("PgNum").value <> "" And _
InputPage.Range("PgNum").value = crateSht.Cells(writeRow, pageColumn).value) Then
'If continueToEnd Then
Exit For
End If
Next
Dim panelCrateData(24) As Variant
Dim panelTableData As Variant
panelTableData = MoveToSht.Range("AK1:AK39")
'writing spoolsheet information to crate sheet
With MoveToSht
If roomColumn <> 0 Then crateSht.Cells(writeRow, roomColumn) = panelTableData(22, 1) '.Range("AK22")
If pageColumn <> 0 Then crateSht.Cells(writeRow, pageColumn) = panelTableData(21, 1) '.Range("AK21")
If sizeColumn <> 0 Then crateSht.Cells(writeRow, sizeColumn) = panelTableData(13, 1) '.Range("AK13")
If widthColumn <> 0 Then crateSht.Cells(writeRow, widthColumn) = panelTableData(12, 1) ' .Range("AK12")
If tagColumn <> 0 Then crateSht.Cells(writeRow, tagColumn) = panelTableData(24, 1)
If typeColumn <> 0 Then crateSht.Cells(writeRow, typeColumn) = panelTableData(23, 1)
panelCrateData(0) = Round(CDbl(Replace(.Range("X35").Text, "SQFT", "")), 2)
panelCrateData(1) = panelTableData(15, 1) '.Range("AK15")
panelCrateData(2) = panelTableData(14, 1) '.Range("AK14")
panelCrateData(3) = panelTableData(17, 1) '.Range("AK17")
panelCrateData(4) = panelTableData(16, 1) '.Range("AK16")
panelCrateData(5) = panelTableData(18, 1) '.Range("AK18")
panelCrateData(6) = panelTableData(20, 1) '.Range("AK20")
panelCrateData(7) = panelTableData(19, 1) '.Range("AK19")
panelCrateData(8) = panelTableData(25, 1) '.Range("AK23")
panelCrateData(9) = panelTableData(26, 1) '.Range("AK24")
panelCrateData(10) = panelTableData(27, 1) '.Range("AK25")
panelCrateData(11) = panelTableData(29, 1) '.Range("AK27")
panelCrateData(12) = panelTableData(30, 1) '.Range("AK28")
panelCrateData(13) = panelTableData(31, 1) '.Range("AK29")
panelCrateData(14) = panelTableData(28, 1) '.Range("AK26")
panelCrateData(15) = panelTableData(34, 1) '.Range("AK32")
panelCrateData(16) = panelTableData(33, 1) '.Range("AK31")
panelCrateData(17) = panelTableData(35, 1) '.Range("AK33")
panelCrateData(18) = panelTableData(36, 1) '.Range("AK34")
panelCrateData(19) = panelTableData(37, 1) '.Range("AK35")
panelCrateData(20) = panelTableData(38, 1) '.Range("AK36")
panelCrateData(21) = panelTableData(39, 1) '.Range("AK37")
panelCrateData(22) = .Range("AU19")
'Holdback Info
panelCrateData(23) = .Range("AU12")
panelCrateData(24) = .Range("AU14")
'Additional Saddles
crateSht.Range(crateSht.Cells(writeRow, infoTableCol), crateSht.Cells(writeRow, infoTableCol + 24)) = panelCrateData ' "M" & writeRow & ":AK" & writeRow) = panelCrateData
End With
For writeRow = 2 To 500
If Len(crateSht.Range("A" & writeRow).value) = 0 Then ' Or crateSht.Range("A" & writeRow).value = InputPage.Range("RoomNum").value Then
'If continueToEnd Then
Exit For
End If
Next
Dim lastRow As Integer
lastRow = writeRow - 1
Dim totSqft As Double
totSqft = WorksheetFunction.Sum(crateSht.Range(crateSht.Cells(2, infoTableCol), crateSht.Cells(lastRow, infoTableCol))) '(crateSht 2:M" & lastRow))
Application.PrintCommunication = False
With crateSht
.PageSetup.PrintArea = "$A$1:$H$" & CStr(lastRow)
.PageSetup.PrintTitleRows = "$1:$1"
If lastRow = 2 Then .PageSetup.CenterHeader = "#" & MoveToSht.Range("AK3").value
.PageSetup.RightFooter = CStr(lastRow - 1) & " PANELS" & vbLf & "TOUCH UP KIT" & vbLf & "INTERCONNECTORS" _
& vbLf & "GLOVES" & vbLf & "T-BAR CLIPS" & vbLf & "INSULATION ON PANEL"
.PageSetup.RightHeader = CStr(totSqft) & " SQFT"
End With
Application.PrintCommunication = True
With frontSht
.Cells(11, 2) = lastRow - 1
.Cells(30, 2) = totSqft
End With
MoveToWkb.SaveAs filename:=FileLocation, FileFormat:=50
MoveToWkb.Close False
Set MoveToWkb = Nothing
'**********************************************************************************'
'Add new entry to recent panels table, unless room number already exists then replace that entry with the current info=
Call AddRecentPanelData
MoveFromSht.Delete
newXL.Application.ScreenUpdating = True
newXL.Application.DisplayAlerts = True
newXL.Application.AskToUpdateLinks = True
Application.Calculation = xlCalculationAutomatic
Set MoveFromWkb = Nothing
Set MoveFromSht = Nothing
Set MoveToSht = Nothing
newXL.Workbooks.Open FileLocation ', UpdateLinks:=False ', ReadOnly:=False
Set newXL = Nothing
Else
MoveToWkb.Close SaveChanges:=False
Set MoveToWkb = Nothing
newXL.Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False
MoveFromSht.Delete
Application.Calculation = xlCalculationAutomatic
Set newXL = Nothing
Set MoveFromWkb = Nothing
Set MoveFromSht = Nothing
Set MoveToSht = Nothing
End If
Exit Sub
'#########################################################################################
ErrorHandler:
Dim Msg As String
If Err.number <> 0 Or Err.number <> 20 Then
Msg = "Error # " & Str(Err.number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Call ReactiveUpdating
End Sub
So Workbook A uses this sub to create Workbook B/Instance B and save worksheets to it. The problem is, when Workbook A tries to add the 20th worksheet (sometimes 24th or 23rd but consistently in this area) there is an error in opening Workbook B in Instance B on this line (a couple scrolls up from the bottom) causing the code to break:
newXL.Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False
Method 'Open' of object 'Workbooks' failed
If I click continue after this error pops up, it completes without an issue, but Workbook B in Instance B is corrupt. Also, if I click the X to close it Excel crashes, and Workbook B is corrupt/unable to open.
The strange thing is, it will always crash after the same number of worksheets are saved (between 20-23 worksheets). Even when I tried closing both workbooks and instances down completely after saving 19 times (just before the expected crash), saving the 20th worksheet still caused a crash.
This only started happening about a month ago, and it occurs on all the computers we have tested it on. We have even tested year old versions of the workbook, that certainly never had this issue, and they all have the same issue.
Please let me know if you can offer any help or need any more detail, any insight is greatly appreciated!
After a lot of work trying to change around the saving/opening process of the workbooks, I managed to figure out the issue. The workbook being saved (Workbook B) contained an ActiveX List Box control object, and after getting rid of it the issue went away. Hopefully this saves somebody the hours it took me to solve it!