1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

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

Discussion in 'Business Applications' started by kronk, Apr 13, 2009.

Thread Status:
Not open for further replies.
Advertisement
  1. kronk

    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
     
  2. Zack Barresse

    Zack Barresse

    Joined:
    Jul 25, 2004
    Messages:
    5,452
    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.
     
  3. kronk

    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).
     
  4. Rollin_Again

    Rollin_Again

    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
     
  5. kronk

    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.
     
  6. Rollin_Again

    Rollin_Again

    Joined:
    Sep 4, 2003
    Messages:
    4,912
    Email your sample workbook to Rollin_Again at hotmail dot com

    Regards,
    Rollin
     
  7. kronk

    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.
     
  8. Rollin_Again

    Rollin_Again

    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
     
  9. Zack Barresse

    Zack Barresse

    Joined:
    Jul 25, 2004
    Messages:
    5,452
    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.
     
  10. Rollin_Again

    Rollin_Again

    Joined:
    Sep 4, 2003
    Messages:
    4,912
    Zack,

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

    Regards,
    Rollin
     
  11. Zack Barresse

    Zack Barresse

    Joined:
    Jul 25, 2004
    Messages:
    5,452
    Stupid simple (for me), zack AT barresse DOT com. :cool:
     
  12. kronk

    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.
     
  13. Sponsor

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 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/818358

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice