none
Code Crashing Word Only on Some Machines RRS feed

  • General discussion

  • In our office, we use an automated requisition sheet that I put together sometime back in 2012. It has worked fine for years until recently when our business just upgraded all of its machines to Office Professional Plus 2016. The macro seems to crash on some machines and not others. I have attempted to step through the code to find out where the issue is, and very strangely, the code does not crash if I step through or even if I hit the play button inside the VBA editor. It only crashed if I activate the macro through the Calculate button at the bottom of the Word document. Any help here is appreciated.

    The document has two buttons at the bottom. The Load Vendors button populates the vendor drop down from a lookup spreadsheet. Once a vendor is chosen, the user populates the table with part no, description, quantity, and cost per unit measure. When the Calculate button is pressed, it tallies up the totals and reformats everything to look pretty. Code follows.

    Sub LoadVendors()
        Dim xlapp As Object
        Dim VendorFile As String
        Dim Vendor As ContentControl
        Dim VendorArray() As String
       
    'Define "Vendor" Drop-down content control.
        Set Vendor = ActiveDocument.ContentControls(1)
        VendorCount = Vendor.DropdownListEntries.Count
        If VendorCount > 0 Then
            For i = 1 To VendorCount
                Vendor.DropdownListEntries(1).Delete
            Next i
        End If

    'Rem Set-up.
        MyFile = "F:\Electro-Mechanical\EM Supplies\Requisitions\Smart Requisition\Vendor Lookup.xlsx"

    'Check if Excel is already open.
        AlreadyOpen = False
        If Tasks.Exists(Name:="Microsoft Excel") = False Then

    'If Excel is not open, then open it.
            Set xlapp = CreateObject("Excel.Application")
        ElseIf Tasks.Exists(Name:="Microsoft Excel") = True Then

    'If Excel is already open, return object.
            AlreadyOpen = True
            Set xlapp = GetObject(, "Excel.Application")
            Else
            
    'If Excel not found,
            MsgBox ("MS Excel could not be opened.")
            End
        End If

    'Make Excel invisible.
        xlapp.Application.Visible = False

    'Open the workbook.
        Set ExcelFile = xlapp.Workbooks.Open(MyFile)

    'Count list entries.
        R = 2
        Do While xlapp.Worksheets("Sheet1").Cells(R, 1).Value <> ""
        R = R + 1
        Loop
        LastRow = R - 1
       
        ReDim VendorArray(2 To LastRow)
       
    'Populate VendorArray.
        For i = 2 To LastRow
            VendorArray(i) = xlapp.Worksheets("Sheet1").Cells(i, 1).Value
        Next i
       
    'Close Excel file and application if not previously open.
        If AlreadyOpen = False Then
            xlapp.Quit
            Set xlapp = Nothing
        Else
            ExcelFile.Close
            xlapp.Application.Visible = True
        End If
        Word.Application.Activate
       
    'Transfer Vendor data to Requisition form.
        For i = 2 To LastRow
            Vendor.DropdownListEntries.Add VendorArray(i)
        Next i
    End Sub
    Sub MoveVendorInfoToTable1()
       
        Dim xlapp As Object
        Dim VendorFile As String
        Dim Vendor As ContentControl
       
    'Define "Vendor" Drop-down content control.
        Set Vendor = ActiveDocument.ContentControls(1)
       
    'Rem Set-up.
        MyFile = "F:\Electro-Mechanical\EM Supplies\Requisitions\Smart Requisition\Vendor Lookup.xlsx"

    'Check if Excel is already open.
        AlreadyOpen = False
        If Tasks.Exists(Name:="Microsoft Excel") = False Then

    'If Excel is not open, then open it.
            Set xlapp = CreateObject("Excel.Application")
        ElseIf Tasks.Exists(Name:="Microsoft Excel") = True Then

    'If Excel is already open, return object.
            AlreadyOpen = True
            Set xlapp = GetObject(, "Excel.Application")
            Else
            
    'If Excel not found,
            MsgBox ("MS Excel could not be opened.")
            End
        End If

    'Make Excel invisible.
        xlapp.Application.Visible = False

    'Open the workbook.
        Set ExcelFile = xlapp.Workbooks.Open(MyFile)

    'Count list entries.
        R = 2
        Do While xlapp.Worksheets("Sheet1").Cells(R, 1).Value <> ""
        R = R + 1
        Loop
        LastRow = R
       
    'Compare list entries with Vendor choice.
        FoundRow = 0
        For i = 2 To LastRow
            If Vendor.Range.Text = xlapp.Worksheets("Sheet1").Cells(i, 1).Value Then
                FoundRow = i
                GoTo SkipOut
            End If
        Next i
           
    SkipOut:

    'Initialize Vendor fields.
        StreetAddress = ""
        City = ""
        State = ""
        ZipCode = ""
        Phone = ""
        Fax = ""
        Website = ""
        Email = ""
        Attention = ""

    'Assign Vendor fields.
        If FoundRow <> 0 Then
            StreetAddress = xlapp.Worksheets("Sheet1").Cells(FoundRow, 2).Value
            City = xlapp.Worksheets("Sheet1").Cells(FoundRow, 3).Value
            State = xlapp.Worksheets("Sheet1").Cells(FoundRow, 4).Value
            ZipCode = xlapp.Worksheets("Sheet1").Cells(FoundRow, 5).Value
            If City = "" Then
                CityStateZipCode = State & " " & ZipCode
            Else
                CityStateZipCode = City & ", " & State & " " & ZipCode
            End If
            Phone = xlapp.Worksheets("Sheet1").Cells(FoundRow, 6).Value
            Fax = xlapp.Worksheets("Sheet1").Cells(FoundRow, 7).Value
            Website = xlapp.Worksheets("Sheet1").Cells(FoundRow, 8).Value
            Email = xlapp.Worksheets("Sheet1").Cells(FoundRow, 9).Value
            Attention = xlapp.Worksheets("Sheet1").Cells(FoundRow, 10).Value
        End If
       
    'Close Excel file and application if not previously open.
        If AlreadyOpen = False Then
            xlapp.Quit
            Set xlapp = Nothing
        Else
            ExcelFile.Close
            xlapp.Application.Visible = True
        End If
        Word.Application.Activate
       
    'Transfer Vendor data to Requisition form.
        If FoundRow <> 0 Then
            ActiveDocument.Tables(1).Cell(1, 2).Range.Select
            Selection.Range.Text = "Phone: " & Phone
       
            ActiveDocument.Tables(1).Cell(2, 1).Range.Select
            Selection.Range.Text = "Address: " & StreetAddress
       
            ActiveDocument.Tables(1).Cell(2, 2).Range.Select
            Selection.Range.Text = "Fax: " & Fax
       
            ActiveDocument.Tables(1).Cell(3, 1).Range.Select
            Selection.Range.Text = "City, State, Zip: " & CityStateZipCode
       
            ActiveDocument.Tables(1).Cell(3, 2).Range.Select
            Selection.Range.Text = "Website: " & Website

            ActiveDocument.Tables(1).Cell(4, 1).Range.Select
            Selection.Range.Text = "Attention: " & Attention
       
            ActiveDocument.Tables(1).Cell(4, 2).Range.Select
            Selection.Range.Text = "E-mail: " & Email
        End If
    End Sub
    Sub CalcTable2()
       
    'Declare Range Variables
        Dim StockNo_Description As Range
        Dim Qty_UOM As Range
        Dim NewText As Variant
       
    ' Define Row Count
        LastRow = ActiveDocument.Tables(2).Rows.Count
        SecondToLastRow = LastRow - 1
       
    'Format "Unit Price" cells.
        For i = 4 To SecondToLastRow
            ActiveDocument.Tables(2).Cell(i, 6).Range.Select
            TextLength = Len(Selection.Range.Text)
            NewText = ""
            For x = 1 To TextLength - 1
                If Mid(Selection.Range.Text, x, 1) <> "," Then
                    If Mid(Selection.Range.Text, x, 1) <> "$" Then
                        NewText = NewText & Mid(Selection.Range.Text, x, 1)
                    End If
                End If
            Next x
            TemporaryTextString = Selection.Range.Text
            ActiveDocument.Tables(2).Cell(i, 6).Range.Select
            FormattedText = Format(NewText, "$#,##0.00")
            Selection.Range.Text = FormattedText

            With Selection
                .ParagraphFormat.Alignment = wdAlignParagraphCenter
                .Cells.VerticalAlignment = wdCellAlignVerticalCenter
            End With
        Next i
       
    'Calculate "price" cells.
        For i = 4 To SecondToLastRow
            ActiveDocument.Tables(2).Cell(i, 7).Range.Select
            Selection.Range.Text = ""
            ActiveDocument.Tables(2).Cell(i, 7).Range.Select
            Selection.MoveLeft Unit:=wdCharacter, Count:=1
            FormulaString = "=R" & i & "C4*R" & i & "C6"
            Selection.InsertFormula Formula:=FormulaString
            Selection.MoveDown Unit:=wdLine, Count:=1
        Next i
       
    'Format "Price" cells.
        For i = 4 To SecondToLastRow
            ActiveDocument.Tables(2).Cell(i, 7).Range.Select
            TemporaryText = Val(Selection.Range.Text)
            TemporaryTextString = Selection.Range.Text
            If Mid(TemporaryTextString, 1, 1) <> "$" Then
                FormattedText = Format(TemporaryText, "$#,##0.00")
                Selection.Range.Text = FormattedText
            End If
            With Selection
                .ParagraphFormat.Alignment = wdAlignParagraphCenter
                .Cells.VerticalAlignment = wdCellAlignVerticalCenter
            End With
        Next i

    'Calculate and format "Total" cell.
        ActiveDocument.Tables(2).Cell(LastRow, 2).Range.Select
        Selection.Range.Text = ""
        ActiveDocument.Tables(2).Cell(LastRow, 2).Range.Select
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.InsertFormula Formula:="=SUM(ABOVE)", NumberFormat:=""
        With Selection
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Cells.VerticalAlignment = wdCellAlignVerticalCenter
        End With
       
    'Format "Stock No." and "Description" cells.
        With ActiveDocument
            Set StockNo_Description = .Range(Start:=.Tables(2).Cell(4, 2).Range.Start, _
                End:=.Tables(2).Cell(SecondToLastRow, 3).Range.End)
            StockNo_Description.Select
        End With
        With Selection
            .ParagraphFormat.Alignment = wdAlignParagraphLeft
            .Cells.VerticalAlignment = wdCellAlignVerticalCenter
        End With
       
    'Format "Qty." and "UOM" cells.
        With ActiveDocument
            Set Qty_UOM = .Range(Start:=.Tables(2).Cell(4, 4).Range.Start, _
                End:=.Tables(2).Cell(SecondToLastRow, 5).Range.End)
            Qty_UOM.Select
        End With
        With Selection
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Cells.VerticalAlignment = wdCellAlignVerticalCenter
        End With

    'Make sure there is at least one populated "Qty." field.
        Populated = 0
        For i = 4 To SecondToLastRow
            ActiveDocument.Tables(2).Cell(i, 4).Range.Select
            TemporaryTextString = Selection.Range.Text
            If Len(TemporaryTextString) >= 3 Then
                Populated = Populated + 1
            End If
        Next i
        If Populated = 0 Then
            UserInput = MsgBox("All quantity fields are empty!" & Chr(10) & "These rows are flagged for deletion." & Chr(10) & "Delete them?", vbYesNo, "Warning!")
            If UserInput = vbNo Then
                GoTo RedefineRowCount
            End If
        End If

    'Delete any row having an empty "Qty." field.
    'Add an apostrophe to the beginning of each line in this section to avoid deleting any row having an empty "Qty." field.
        Row = 4
        For i = 4 To SecondToLastRow
            ActiveDocument.Tables(2).Cell(Row, 4).Range.Select
            TemporaryTextString = Selection.Range.Text
            If Len(TemporaryTextString) < 3 Then
                Selection.Rows.Delete
                Row = Row - 1
                SecondToLastRow = SecondToLastRow - 1
            End If
            Row = Row + 1
        Next i
       
    RedefineRowCount:
    ' Redefine Row Count
        LastRow = ActiveDocument.Tables(2).Rows.Count
        SecondToLastRow = LastRow - 1
       
    'Number the "Line No." cells.
        For i = 4 To SecondToLastRow
        ActiveDocument.Tables(2).Cell(i, 1).Range.Select
            FormulaString = "=" & i - 3
            Selection.InsertFormula Formula:=FormulaString
            With Selection
                .ParagraphFormat.Alignment = wdAlignParagraphCenter
                .Cells.VerticalAlignment = wdCellAlignVerticalCenter
            End With
        Next i
    ExitWithoutDoingAnything:
    End Sub

     
    Thursday, June 29, 2017 12:49 PM