Excel Macro - converting excel to word doc - stops after row 29

Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

kronk

Thread Starter
Joined
Apr 13, 2009
Messages
5
I run a weekly excel 2007 macro that converts a spreadsheet to a Word document, but it stops after row 29 of data. Any spreadsheet with 29 rows or less works fine. If I have 34 rows of data, the macro hangs. See below for script. Any help would be appreciated.

Public Sub AddControls(WrdApp As Word.Application, CurRow As Integer)
Dim OptChecked As Boolean
Dim GrpName As String
GrpName = "Grp" & CurRow
'Calculate the colors based on the cell information.
CurRange = "F" & CurRow & ".." & "F" & CurRow
Range(CurRange).Select

If InStr(1, UCase(ActiveCell.Text), "X SRM") > 0 Then 'SRM
OptChecked = True
Else
OptChecked = False
End If

SetCellBG WrdApp, True
WrdApp.Selection.TypeText Text:="Governance:" & vbCrLf

Set RadioObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.OptionButton.1")
With RadioObj.OLEFormat.Object
.GroupName = GrpName
.Caption = "SRM"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With

If InStr(1, UCase(ActiveCell.Text), "X PPO") > 0 Then ' PPO
OptChecked = True
Else
OptChecked = False
End If

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set RadioObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.OptionButton.1")
With RadioObj.OLEFormat.Object
.GroupName = GrpName
.Caption = "PPO"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With

If InStr(1, UCase(ActiveCell.Text), "X ITAC") > 0 Then ' ITAC
OptChecked = True
Else
OptChecked = False
End If

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set RadioObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.OptionButton.1")
With RadioObj.OLEFormat.Object
.GroupName = GrpName
.Caption = "ITAC"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With

If InStr(1, UCase(ActiveCell.Text), "X ITSC") > 0 Then ' ITSC
OptChecked = True
Else
OptChecked = False
End If


WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set RadioObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.OptionButton.1")
With RadioObj.OLEFormat.Object
.GroupName = GrpName
.Caption = "ITSC"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With


If InStr(1, UCase(ActiveCell.Text), "X ITSG") > 0 Then ' ITSG
OptChecked = True
Else
OptChecked = False
End If


WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set RadioObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.OptionButton.1")
With RadioObj.OLEFormat.Object
.GroupName = GrpName
.Caption = "ITSG"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With

'CheckBoxes
CurRange = "G" & CurRow & ".." & "G" & CurRow
Range(CurRange).Select

WrdApp.Selection.MoveRight Unit:=wdCell

SetCellBG WrdApp, True
WrdApp.Selection.TypeText Text:="Approvals:" & vbCrLf

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), "X GIS EXPENSE") > 0 Then ' GIS EXPENSE
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "GIS Expense"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
.Width = 72.75
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), "X PPO#") > 0 Then ' PPO #
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "PPO #"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
.Width = 58.6
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeText Text:=" "
Set TxtObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.TextBox.1")

With TxtObj.OLEFormat.Object
.Font.Name = "Arial"
.Font.Size = 8
.Width = 31.5
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph


Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), "X AR#") > 0 Then ' PSR #
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "PSR #"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
.Width = 58.6
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeText Text:=" "

Set TxtObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.TextBox.1")

With TxtObj.OLEFormat.Object
.Font.Name = "Arial"
.Font.Size = 8
.Width = 31.5
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph
WrdApp.Selection.TypeParagraph

With WrdApp.Selection
.Font.Name = "Arial"
.Font.Size = 8
.Font.Italic = True
.Font.Bold = False
.TypeText Text:="(Fill in appropriate PPO and/or PSR#s)"
End With

'PPO STATUS
CurRange = "H" & CurRow & ".." & "H" & CurRow
Range(CurRange).Select

WrdApp.Selection.MoveRight Unit:=wdCell

SetCellBG WrdApp, True
WrdApp.Selection.TypeText Text:="PPO Status:" & vbCrLf

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), "X INITIATING") > 0 Then ' INITIATING
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "Initiating"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), "X SUBMITTED") > 0 Then ' Submitted
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "Submitted"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), "X IN-PROCESS") > 0 Then ' In-Process
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "In-process"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), "X COMPLETED") > 0 Then ' Completed
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "Completed"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), "X NON-PPO INITIATIVE") > 0 Then ' Non-PPO Initiative
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "Non-PPO Initiative"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph
WrdApp.Selection.TypeParagraph

With WrdApp.Selection
.Font.Name = "Arial"
.Font.Size = 8
.Font.Italic = True
.Font.Bold = False
.TypeText Text:="(Select status based on status with PPO)"
End With


'ALIGNMENT LEVEL
CurRange = "I" & CurRow & ".." & "I" & CurRow
Range(CurRange).Select

WrdApp.Selection.MoveRight Unit:=wdCell

SetCellBG WrdApp, True
WrdApp.Selection.TypeText Text:="Alignment Level:" & vbCrLf

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), UCase("X Aligned to Strategic Initiatives")) > 0 Then ' Aligned to Strategic Initiatives
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "Aligned to Strategic Initiatives"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
.Width = 165
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), UCase("X Aligned to Belt Tightening")) > 0 Then ' Aligned to Belt Tightening
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "Aligned to Belt Tightening"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
.Width = 165
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), UCase("X Aligned to Executive Sponsor")) > 0 Then ' Aligned to executive sponsor
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "Aligned to executive sponsor"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
.Width = 165
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

Set ChkObj = WrdApp.Selection.InlineShapes.AddOLEControl("Forms.CheckBox.1")

If InStr(1, UCase(ActiveCell.Text), UCase("X Aligned to Non-PPO Initiative")) > 0 Then ' Aligned to Non-PPO initiative
OptChecked = True
Else
OptChecked = False
End If

With ChkObj.OLEFormat.Object
.Caption = "Aligned to Non-PPO initiative"
.Font.Name = "Arial"
.Font.Size = 8
.Value = OptChecked
.Width = 165
End With

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph

WrdApp.Selection.Collapse Direction:=wdCollapseEnd
WrdApp.Selection.TypeParagraph
WrdApp.Selection.TypeParagraph

With WrdApp.Selection
.Font.Name = "Arial"
.Font.Size = 8
.Font.Italic = True
.Font.Bold = False
.TypeText Text:="(Select appropriate or work effort alignment)"
End With

End Sub
Public Sub CopyWorkSheet(WkSheet As Worksheet, WkBkTo As Workbook, WkBkFrom As Workbook, ByRef CurRow As Integer)
Dim EndInt As Long
Dim X As Long
Dim CurRange As String
Dim ChkRange As String
Dim PasteRange As String
Dim MCellData As String

WkSheet.Activate
Range("A1").Select
Selection.End(xlDown).Select
EndInt = Application.ActiveCell.Row + 1

For X = 2 To EndInt

frmStatus.lblProcess.Caption = "Processing WorkSheet " & WkSheet.Name
frmStatus.lblStatus.Caption = "Processing item " & Format(X, "###,###,##0") & " of " & Format(EndInt, "###,###,##0")
frmStatus.Repaint

WkSheet.Activate

'Check to see if column R has an X in it.
ChkRange = "R" & X & ".." & "R" & X
Range(ChkRange).Select
MCellData = Application.ActiveCell.Value

If UCase(MCellData) = "X" Then
CurRange = "A" & X & ".." & "Q" & X
Range(CurRange).Select
Selection.Copy

WkBkTo.Activate
PasteRange = "A" & CurRow & ".." & "A" & CurRow
Range(PasteRange).Select

Application.ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

CurRow = CurRow + 1

End If


Next
End Sub
Public Sub CopyWorkSheets()
Dim WkBkFrom As New Workbook
Dim WkBkTo As New Workbook
Dim WkBkFinal As New Workbook
Dim WkSheet As Worksheet
Dim CurRow As Integer
Dim FromFileName As String
Dim EndInt As Long
Dim FullRange As String

FromFileName = InputBox("Input Weekly Status File To Load", "Input File name", "C:\Documents and Settings\testname\My Documents\Company\Strategy\Dept\Weekly Status Reports\Weekly Status Report 031309.xls")
If FromFileName <> "" Then

Application.ScreenUpdating = False

Set WkBkTo = Application.ActiveWorkbook
Set WkBkFinal = Application.Workbooks.Add

'On Error Resume Next
Set WkBkFrom = Application.Workbooks.Open(FromFileName)

If Err.Number <> 0 Then
MsgBox "Error Loading File " & FromFileName
Else

CurRow = 1

WkBkFrom.Worksheets(1).Select

frmStatus.lblProcess.Caption = "Transfering Worksheets.."
frmStatus.lblStatus.Caption = "No Items Processed.."
frmStatus.Show

For Each WkSheet In WkBkFrom.Worksheets
CopyWorkSheet WkSheet, WkBkFinal, WkBkFrom, CurRow
Next

'Now lets loop through the final worksheet and copy this data to word.
CreateWordDoc CurRow, WkBkFinal

WkBkFrom.Close False
WkBkFinal.Close False

'Application.Quit
frmStatus.Hide

End If

End If


End Sub
Public Sub CreateWordDoc(CurRow, WkBk As Workbook)
Dim WrdApp As New Word.Application
Dim WrdDoc As Word.Document
Dim HdrTable As Table
Dim FtrTable As Table
Dim HtmlStr As String
Dim DtlTable As Table
Dim WrdRange As Word.Range
Dim WrdSel As Word.Selection
Dim CurRange As String
Dim CurStr As String
Dim OnFunctionColorIndex As Long
Dim OnScheduleColorIndex As Long
Dim OnBudgetColorIndex As Long
Dim NoSuprisesColorIndex As Long
Dim CurFnt As Font
Dim Lead As String
Dim Sponsor As String
Dim RecentAcc As String
Dim Description As String
Dim ToDo As String
Dim Issues As String
Dim CurTableRow As Integer
Dim StatusColumnsSet As Boolean
Dim Governance As String
Dim Approvals As String
Dim PPOStatus As String
Dim Alignment As String
Dim CurCol As Column
Dim RadioObj As InlineShape
Dim X As Integer

frmStatus.lblProcess.Caption = "Creating Word Document "
frmStatus.lblStatus.Caption = "Opening Microsoft Word"
frmStatus.Repaint

Set WrdDoc = WrdApp.Documents.Add

With WrdDoc.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With WrdDoc.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(1)
.BottomMargin = InchesToPoints(1)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With

SetupHeader WrdApp

CurRow = CurRow - 1

StatusColumnsSet = False

For X = 1 To CurRow

frmStatus.lblProcess.Caption = "Building Word Document "
frmStatus.lblStatus.Caption = "Processing item " & Format(X, "###,###,##0") & " of " & Format(CurRow, "###,###,##0")
frmStatus.Repaint

WrdApp.Selection.EndKey Unit:=wdStory
WrdApp.Selection.TypeParagraph

'Create the header table
Set HdrTable = WrdDoc.Tables.Add(WrdApp.Selection.Range, 1, 2, wdWord9TableBehavior, wdAutoFitFixed)

HdrTable.Columns(1).SetWidth ColumnWidth:=233.4, RulerStyle:=wdAdjustNone
HdrTable.Columns(2).SetWidth ColumnWidth:=354, RulerStyle:=wdAdjustNone

If X = 1 Then
With HdrTable
SetCellBG WrdApp, True
WrdApp.Selection.TypeText Text:="Project"
WrdApp.Selection.MoveRight Unit:=wdCell
SetCellBG WrdApp, True
WrdApp.Selection.TypeText Text:="Project Indicators/Status"
WrdApp.Selection.MoveRight Unit:=wdCell
SetCellBG WrdApp, False
WrdApp.Selection.MoveRight Unit:=wdCell
SetCellBG WrdApp, False
WrdApp.Selection.MoveRight Unit:=wdCell
SetCellBG WrdApp, False
End With
CurTableRow = 3
Else
WrdApp.Selection.MoveUp Unit:=wdLine, Count:=1
WrdApp.Selection.Delete Unit:=wdCharacter, Count:=1
CurTableRow = 1
End If

' If X = 2 Then
' HdrTable.Rows(CurTableRow).Range.Select
' WrdApp.Selection.InsertRowsBelow 1
' CurTableRow = CurTableRow + 1
' End If

HdrTable.Rows(CurTableRow).Range.Select

WkBk.Activate
CurRange = "A" & X & ".." & "A" & X
Range(CurRange).Select
CurStr = Application.ActiveCell.Value

'Calculate the colors based on the cell information.
CurRange = "E" & X & ".." & "E" & X
Range(CurRange).Select

'On Function
Set CurFnt = ActiveCell.Characters(Start:=3, Length:=1).Font
OnBudgetColorIndex = GetFontIndex(CurFnt)

'On Schedule
Set CurFnt = ActiveCell.Characters(Start:=14, Length:=1).Font
OnScheduleColorIndex = GetFontIndex(CurFnt)

'On Budget
Set CurFnt = ActiveCell.Characters(Start:=25, Length:=1).Font
OnFunctionColorIndex = GetFontIndex(CurFnt)

'No Suprises
Set CurFnt = ActiveCell.Characters(Start:=35, Length:=1).Font
NoSuprisesColorIndex = GetFontIndex(CurFnt)

'Lead
CurRange = "C" & X & ".." & "C" & X
Range(CurRange).Select

Lead = ActiveCell.Value

'Sponsor
CurRange = "B" & X & ".." & "B" & X
Range(CurRange).Select

Sponsor = ActiveCell.Value

'Governance
CurRange = "f" & X & ".." & "f" & X
Range(CurRange).Select
Governance = ActiveCell.Value

'Approvals
CurRange = "g" & X & ".." & "g" & X
Range(CurRange).Select
Approvals = ActiveCell.Value

'PPO Status
CurRange = "h" & X & ".." & "h" & X
Range(CurRange).Select
PPOStatus = ActiveCell.Value

'Alignment
CurRange = "i" & X & ".." & "i" & X
Range(CurRange).Select
Alignment = ActiveCell.Value

'Recent Accomplishments
CurRange = "o" & X & ".." & "o" & X
Range(CurRange).Select
RecentAcc = ActiveCell.Value

'To Do
CurRange = "p" & X & ".." & "p" & X
Range(CurRange).Select
ToDo = ActiveCell.Value

'Issues
CurRange = "q" & X & ".." & "q" & X
Range(CurRange).Select
Issues = ActiveCell.Value

'Scope Summary
CurRange = "N" & X & ".." & "N" & X
Range(CurRange).Select
Description = ActiveCell.Value

With WrdApp.Selection
.Range.ListFormat.RemoveNumbers
.Rows.HeightRule = wdRowHeightAuto
.Rows.Height = InchesToPoints(0)

SetCellBG WrdApp, False

WrdApp.Selection.TypeText Text:=CurStr
WrdApp.Selection.MoveRight Unit:=wdCell

'Create the Status Dtl
Set DtlTable = WrdDoc.Tables.Add(WrdApp.Selection.Range, 1, 4, wdWord9TableBehavior, wdAutoFitFixed)

DtlTable.Select

WrdApp.Selection.Font.Size = 12
WrdApp.Selection.Font.Bold = True

With DtlTable

With WrdApp.Selection.Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorAutomatic
End With

WrdApp.Selection.TypeText Text:="On Function"
WrdApp.Selection.Shading.BackgroundPatternColor = OnBudgetColorIndex
WrdApp.Selection.MoveRight Unit:=wdCell
WrdApp.Selection.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
WrdApp.Selection.TypeText Text:="On Schedule"
WrdApp.Selection.Shading.BackgroundPatternColor = OnScheduleColorIndex
WrdApp.Selection.MoveRight Unit:=wdCell
WrdApp.Selection.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
WrdApp.Selection.TypeText Text:="On Budget"
WrdApp.Selection.Shading.BackgroundPatternColor = OnFunctionColorIndex
WrdApp.Selection.MoveRight Unit:=wdCell
WrdApp.Selection.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
WrdApp.Selection.TypeText Text:="No Surprises"
WrdApp.Selection.Shading.BackgroundPatternColor = NoSuprisesColorIndex

If StatusColumnsSet = False Then
WrdApp.Selection.Tables(1).Columns(1).SetWidth ColumnWidth:=90, RulerStyle:=wdAdjustNone
WrdApp.Selection.Tables(1).Columns(2).SetWidth ColumnWidth:=84, RulerStyle:=wdAdjustNone
WrdApp.Selection.Tables(1).Columns(3).SetWidth ColumnWidth:=84, RulerStyle:=wdAdjustNone
WrdApp.Selection.Tables(1).Columns(4).SetWidth ColumnWidth:=84, RulerStyle:=wdAdjustNone
StatusColumnsSet = True
End If

End With

End With

HdrTable.Rows(CurTableRow).Range.Select


With WrdApp.Selection
.InsertRowsBelow 1
'.Rows.HeightRule = wdRowHeightAtLeast
'.Rows.Height = InchesToPoints(1.2)

CurTableRow = CurTableRow + 1

.Font.Size = 10
.Font.Bold = True
.TypeText Text:="Scope Summary:"
.TypeParagraph
.Font.Size = 10
.Font.Bold = False
.TypeText Text:=Description
.TypeParagraph
.TypeParagraph
.Font.Size = 10
.Font.Bold = True
.TypeText Text:="Sponsor:"
.TypeParagraph
.Font.Size = 10
.Font.Bold = False
.TypeText Text:=Sponsor
.TypeParagraph
.TypeParagraph
.Font.Size = 10
.Font.Bold = True
.TypeText Text:="Lead:"
.Font.Size = 10
.Font.Bold = False
.TypeParagraph
.TypeText Text:=Lead
.TypeParagraph
.MoveRight Unit:=wdCell

SetCellBG WrdApp, False

.Font.Size = 10
.Font.Bold = True
.TypeText Text:="Recent Accomplishments:"
.TypeParagraph
.Font.Size = 10
.Font.Bold = False
.Range.ListFormat.ApplyBulletDefault
.TypeText Text:=RecentAcc
.TypeParagraph
.Range.ListFormat.RemoveNumbers
.TypeParagraph

.Font.Size = 10
.Font.Bold = True
.TypeText Text:="To Do (Next 30 days):"
.TypeParagraph
.Font.Size = 10
.Font.Bold = False
.Range.ListFormat.ApplyBulletDefault
.TypeText Text:=ToDo
.TypeParagraph
.Range.ListFormat.RemoveNumbers
.TypeParagraph

.Font.Size = 10
.Font.Bold = True
.TypeText Text:="Issues and Concerns:"
.TypeParagraph
.Font.Size = 10
.Font.Bold = False
.Range.ListFormat.ApplyBulletDefault
.TypeText Text:=Issues
.TypeParagraph
.Range.ListFormat.RemoveNumbers

End With


WrdApp.Selection.EndKey Unit:=wdStory
WrdApp.Selection.TypeParagraph

Set FtrTable = WrdDoc.Tables.Add(WrdApp.Selection.Range, 1, 4, wdWord9TableBehavior, wdAutoFitFixed)

FtrTable.Columns(1).SetWidth ColumnWidth:=131.4, RulerStyle:=wdAdjustNone
FtrTable.Columns(2).SetWidth ColumnWidth:=138, RulerStyle:=wdAdjustNone
FtrTable.Columns(3).SetWidth ColumnWidth:=141.75, RulerStyle:=wdAdjustNone
FtrTable.Columns(4).SetWidth ColumnWidth:=176.25, RulerStyle:=wdAdjustNone

WrdApp.Selection.MoveUp Unit:=wdLine, Count:=1
WrdApp.Selection.Delete Unit:=wdCharacter, Count:=1

AddControls WrdApp, X


Next


WrdApp.Visible = True
WrdApp.Selection.HomeKey Unit:=wdStory, Extend:=wdMove
End Sub
Public Sub SetupHeader(WrdApp As Word.Application)
If WrdApp.ActiveWindow.View.SplitSpecial <> wdPaneNone Then
WrdApp.ActiveWindow.Panes(2).Close
End If

If WrdApp.ActiveWindow.ActivePane.View.Type = wdNormalView Or WrdApp.ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
WrdApp.ActiveWindow.ActivePane.View.Type = wdPrintView
End If
WrdApp.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
WrdApp.Selection.Font.Size = 12
WrdApp.Selection.Font.Bold = wdToggle
WrdApp.Selection.TypeText Text:="Global Security Operations" & vbCrLf & "Weekly Project Status Report: " & Format(Now, "mm/dd/yyyy") & vbCrLf
WrdApp.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Public Function GetFontIndex(CurFnt As Font) As Long
'35,4,50,43,14,10 = Green
'3,46,9,53 = Red
'36,6,44,40,45 = Yellow

'Dim WrdApp As Word.Application
'WrdApp.Selection.Shading.BackgroundPatternColor = wdcolorlig


Select Case CurFnt.ColorIndex

Case Is = 36, 6, 44, 40, 45
GetFontIndex = wdColorYellow
Case Is = 3, 46, 9, 53
GetFontIndex = wdColorRed
Case Is = 10, 35, 4, 50, 43, 14
GetFontIndex = wdColorGreen
Case Else
GetFontIndex = wdColorGreen
End Select

End Function
Public Function SetCellBG(WrdApp As Word.Application, IsHeader As Boolean)
If IsHeader = True Then
WrdApp.Selection.Font.Size = 12
WrdApp.Selection.Font.Bold = True

With WrdApp.Selection.Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorGray05
End With

Else
WrdApp.Selection.Font.Size = 10
WrdApp.Selection.Font.Bold = True

With WrdApp.Selection.Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorAutomatic
End With
End If

End Function

Private Sub Workbook_Open()
End Sub
 
Joined
Jul 25, 2004
Messages
5,458
Hi there, welcome to the board!

A couple of preliminaries. Plese learn to use the code tags. surround all of your code with [ CODE ] at the beginning (take out the spaces) and [ /CODE ] at the end (take out the spaces). It make it format a little nicer on the board and helps readability.

Secondly, think about indenting your code in a manner which also helps readability.

In your code, you don't tell us what goes where. Some is for Word, some is for Excel. Or are you calling all from within Excel and set a Word object reference? Also, what is frmStatus? You also need to add this dimension line to your AddControls() routine...
Code:
Dim RadioObj As Object, ChkObj As Object, TxtObj As Object
Can you tell us what routine you are running and where you think the erroneous behavior is coming from? This is quite a bit of code, and it'd help us if we knew where to look.
 

kronk

Thread Starter
Joined
Apr 13, 2009
Messages
5
Zack: Thanks for your response. I am new to this board.

The Macro is calling all from within Excel and set a Word object reference. I inherited the code, no not sure where the frmstatus references.

This code is run from a blank worksheet(STATUS REPORT CREATION WORKBOOK NEW, calling another excel spreadsheet (with data), and takes that data and reformats into a word document. the "X" in the SELECT column indicates that this row should be pulled into the Word document.

there must be some COUNTER issue. I could send both the excel workbook with the macro and a workbook with data so you can see the way it works and formats the word document. But the crux of the issue is that if you have more than 29 rows of data, the macro hangs on 29 and doesn't finish, although it builds out a temp workbook (book1).
 
Joined
Sep 4, 2003
Messages
4,912
When you say the macro hangs does it actually throw and an error or does it appear to continue into some endless loop? Please provide more details on what is happening and try to provide us with the last line of code to be executed before hanging. You can always manually stop the code if it is in an endless loop by pressing CTRL + BREAK at the same time to enter debug mode. You can also press ALT + F11 to manually open the VB editor and then press the F8 key to step through the code line by line. If you can include your sample workbook (with any sensitive data removed) that would also be great.

Hello Zack...It's been a while since we chatted. I've been on these boards much less after getting spanked at work for excessive internet usage. It's all TSG's fault :D

Regards,
Rollin
 

kronk

Thread Starter
Joined
Apr 13, 2009
Messages
5
The Macro hangs on row 29. So if I have entered 34 rows of data, the messages says "processing 29 of 34..." but goes no further. I have to delete the operation. I have not tried to step through it yet to debug. I can send the blank worksheet with the macro and one filled with sample scrubbed data to replicate the issue. where should I send it? Thanks in advance.
 

kronk

Thread Starter
Joined
Apr 13, 2009
Messages
5
I sent it to you in a zipped file - the workbook with the macro and the sample excel workbook input that produces the WORD formatted report. If you have more than 29 items to report, the macro hangs on 29.
 
Joined
Sep 4, 2003
Messages
4,912
I'm not sure what is going on when you run the macro but when I run the code using the sample files that you provided and all the records appear to be processing with message "Processesing Item 36 of 36"

Regards,
Rollin
 
Joined
Jul 25, 2004
Messages
5,458
When it hangs, does it give an error message? If not, hit Ctrl + Break (usually on the top-left of a keyboard, near the Pause button). Hit the Debug button on the window and tell us what line is highlighted.
 
Joined
Sep 4, 2003
Messages
4,912
When it hangs, does it give an error message? If not, hit Ctrl + Break (usually on the top-left of a keyboard, near the Pause button). Hit the Debug button on the window and tell us what line is highlighted.
Zack,

What is your email address. I'll forward the workbook to you to see if you can duplicate the error.

Regards,
Rollin
 

kronk

Thread Starter
Joined
Apr 13, 2009
Messages
5
You were able to run 36 items? I could not run more than 29, at which time the message says "processing item 29 of 32" and hangs. No error message. I know the macro looks for certain specific conditions, such as expecting a space after an X in columns F through I. Also, it will print only those rows that have an X in Column R. Today when I ran the report, it hung when it encountered row 21 of 26. I had to go back into the spreadsheet and figure out which row item was causing the issue, and delete any blank characters. I didn't see what the problem was, but then it ran just fine after that. I tried last week to run 32 items, but it hung, so I reduced it to 29, and it ran. It's a mystery to me. something about counters.
 
Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

Users Who Are Viewing This Thread (Users: 0, Guests: 1)

As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 807,865 other people just like you!

Latest posts

Staff online

Members online

Top