Macro is causing Word to freeze and crash

Hi @Lisa C,

Good day to you! Welcome to Microsoft Q&A.

I have received the macro file. Could you please upload the excel file where you are running the macro to Onedrive and share us the link with edit access so that we can easily troubleshoot the issue for you?

Thank you for your valuable time and co-operation. If you have any questions and requirements, please feel free to ask. Looking forward to your response.

 If the answer is helpful, please click "Accept Answer" and kindly upvote it. If you have extra questions about this answer, please click "Comment". 

Note: Please follow the steps in our documentation to enable e-mail notifications if you want to receive the related email notification for this thread.     

re:causing Word to freeze and crash. Can you tried to run it on another PC? I guess most of the reason is out of memory. It is very common when handle huge data by VBA. Alternatively,try generate html instead of word .doc.

Hi @Lisa Cm, 

I have reviewed the file and edited it. Please verify with your excel sheets to see if it works. Here's the updated vba script:  

Function Determine_Max_Row()  ActiveCell.SpecialCells(xlLastCell).Select  MyLastColumn = ActiveCell.column  Max = 1  Temp = 0  For x = 1 To MyLastColumn  Temp = Sheets(1).Cells(rows.Count, x).End(xlUp).Row  If Temp > Max Then  Max = Temp  End If  Next  Determine_Max_Row = Max  End Function 

Function moveCrossTabs()  prompt = InputBox("Please enter the name of first cross tab question as shown in Row 1 Ex. B (QB)", , "B (QB)")  ActiveCell.SpecialCells(xlLastCell).Select  MyLastColumn = ActiveCell.column  Start = 0  Max = 1  For x = 2 To MyLastColumn  If Start > 0 Then  If Cells(1, x) = Empty Then  Exit For  Else  Start = Start + 1  Sheets(1).Columns(x).Cut Destination:=Sheets(2).Columns(Start)  Temp = Sheets(1).Cells(rows.Count, x).End(xlUp).Row  If Temp > Max Then  Max = Temp  End If  End If 

End If  If Start = 0 Then  If Cells(1, x) = prompt Then  Start = Start + 1  Max = Sheets(1).Cells(rows.Count, x).End(xlUp).Row  Sheets(1).Columns(x).Cut Destination:=Sheets(2).Columns(Start)  End If  End If  Next x  moveCrossTabs = Start  End Function 

Function ReplaceTitles(prompt, column, rows) As String  Sheets(1).Activate  For x = 1 To rows  If Cells(x, column) = Empty Then  Cells(x, column) = prompt + " - Not Specified"  End If  If Cells(x, column) = "Other (please specify)" Then  Cells(x, column) = prompt + " - Other"  End If  Next x 

End Function 

Function RemoveEmpty(rows) As Long  deleted = 0  Sheets(1).Activate  x = 1  While x < rows  If Cells(x, 1) = Empty And Cells(x + 1, 1) = Empty Then  Cells(x, 1).EntireRow.Delete  Cells(x, 1).EntireRow.Delete  deleted = deleted + 2  rows = rows - 2  End If  If Cells(x, 1) = Empty Then  Cells(x, 1).EntireRow.Delete  deleted = deleted + 1  rows = rows - 1  End If  x = x + 1  Wend  RemoveEmpty = deleted  End Function 

Function OneColumn_NoCrossTab() As Long  totalrows = 0  ThisWorkbook.Save  Dim LastColumn&, LastRow&, NextRow&, xCol&  LastColumn = Range("A1").CurrentRegion.Columns.Count  Dim countofquestions  countofquestions = 1  For xCol = 2 To LastColumn  LastRow = Cells(rows.Count, xCol).End(xlUp).Row  NextRow = Cells(rows.Count, 1).End(xlUp).Row + 1  ActiveSheet.Cells(NextRow, 1) = "XXXX"  NextRow = NextRow + 1  Range(Cells(1, xCol), Cells(LastRow, xCol)).Cut Cells(NextRow, 1) 

Next xCol  totalrows = Cells(rows.Count, 1).End(xlUp).Row  Application.ScreenUpdating = True  OneColumn_NoCrossTab = totalrows 

End Function 

Function OneColumn(MaxRow) As Long  totalrows = 0  ThisWorkbook.Save  Dim LastColumn&, LastRow&, NextRow&, xCol&  LastColumn = Range("A1").CurrentRegion.Columns.Count  Dim countofquestions  countofquestions = 1  LastRow = MaxRow  Maxrow1 = MaxRow  For xCol = 2 To LastColumn  NextRow = Maxrow1 + 1  ActiveSheet.Cells(NextRow, 1) = "XXXX"  NextRow = NextRow + 1  Maxrow1 = Maxrow1 + 1  Range(Cells(1, xCol), Cells(LastRow, xCol)).Cut Cells(NextRow, 1)  countofquestions = countofquestions + 1  Maxrow1 = Maxrow1 + MaxRow  Next xCol  Sheets(2).Activate  For column = 1 To 1000  If Cells(1, column) = Empty Then  Exit For  End If 

numberofjobs = MaxRow  Sheets(2).Cells(numberofjobs + 1, column) = "XXXX"  numberofjobs = numberofjobs + 1  numberofjobs1 = numberofjobs  For Count = 1 To countofquestions - 1  Range(Cells(1, column), Cells(numberofjobs, column)).Copy Cells(numberofjobs1 + 1, column)  numberofjobs1 = numberofjobs1 + numberofjobs 

totalrows = numberofjobs1  Next Count  Sheets(2).Columns(column).Copy Destination:=Sheets(1).Columns(column + 1) 

Next column  Application.ScreenUpdating = True  OneColumn = totalrows 

End Function 

Function CreateNewWordDoc(rows, crosstabcount)      Dim wrdApp As Word.Application      Dim wrdDoc As Word.Document      Dim i As Integer      Set wrdApp = CreateObject("Word.Application")      wrdApp.Visible = True      Set wrdDoc = wrdApp.Documents.Add       flag = 0       questionno = 0       flag1d = 0      With wrdDoc          For i = 1 To rows              If Cells(i, 1) = "XXXX" Then              flag = 1              questionno = questionno + 1               With wrdApp.Selection               If questionno > 1 Then               .InsertBreak               End If              .ParagraphFormat.SpaceBefore = 0              .ParagraphFormat.SpaceAfter = 0              .ParagraphFormat.Space1              .Font.Name = "Calibri"              .Font.Size = 18              .Font.Bold = True              .Font.Italic = False              .ParagraphFormat.Alignment = wdAlignParagraphCenter              .TypeText Text:=Sheets(3).Cells(questionno, 1)              .Font.Size = 14                .TypeText Text:=" " & Sheets(3).Cells(questionno, 2) & " PAGE: " & Sheets(3).Cells(questionno, 3)              .InsertStyleSeparator              .Style = "List Continue"              .Font.Name = "Calibri"              .Font.Size = "12"              .Font.Bold = True              .ParagraphFormat.SpaceBefore = 0              .ParagraphFormat.SpaceAfter = 0              .ParagraphFormat.Space1              questionenter = Sheets(1).Cells(i + 1, 1)              .TypeText Text:=vbCrLf & vbCrLf & questionenter & " " & Sheets(3).Cells(1, 4) & vbCrLf               End With               flag1d = 1              Else              If flag1d = 0 Then              With wrdApp.Selection              .Font.Size = 12              .Font.Italic = False              .ParagraphFormat.SpaceBefore = 0              .ParagraphFormat.SpaceAfter = 0              .ParagraphFormat.Space1              .TypeText Text:=vbCrLf              .Style = "Normal_verbatim"              .Font.Name = "Calibri"              .Font.Size = 12              .Font.Bold = False              .ParagraphFormat.SpaceBefore = 0              .ParagraphFormat.SpaceAfter = 0              .ParagraphFormat.Space1              Cells(i, 1) = Replace(Cells(i, 1), ". " & vbCrLf, ". ")              Cells(i, 1) = Replace(Cells(i, 1), "." & vbCrLf, ". ")              Cells(i, 1) = Replace(Cells(i, 1), vbCrLf, ". ")              Cells(i, 1) = UCase(Left(Cells(i, 1), 1)) + Right(Cells(i, 1), Len(Cells(i, 1)) - 1)              If Right(Cells(i, 1), 1) = " " Then              Cells(i, 1) = Left(Cells(i, 1), Len(Cells(i, 1)) - 1)              End If              If (Right(Cells(i, 1), 1) = "." Or Right(Cells(i, 1), 1) = "?" Or Right(Cells(i, 1), 1) = "!") Then              .TypeText Text:=Cells(i, 1) & vbCrLf              Else              .TypeText Text:=Cells(i, 1) & "." & vbCrLf              End If              '.Range.ListFormat.ApplyBulletDefault              .InsertStyleSeparator              End With              If i > 1 And flag = 0 And crosstabcount > 0 Then              For x = 1 To crosstabcount              With wrdApp.Selection              .ParagraphFormat.SpaceBefore = 0              .ParagraphFormat.SpaceAfter = 0              .Style = "List Continue 2"              .Font.Name = "Calibri"              .Font.Size = 9              .Font.Bold = False              .Font.Italic = True              .ParagraphFormat.SpaceBefore = 0              .ParagraphFormat.SpaceAfter = 0              .ParagraphFormat.Space1              .TypeText Text:=Cells(i, x + 1)              .Font.Size = 12              .Font.Italic = False              .ParagraphFormat.SpaceBefore = 0              .ParagraphFormat.SpaceAfter = 0              .ParagraphFormat.Space1              .ParagraphFormat.SpaceBefore = 0              .ParagraphFormat.SpaceAfter = 0              .TypeText Text:=vbCrLf              .InsertStyleSeparator              End With              Next x              End If              Else              flag1d = 0              End If              flag = 0          End If          Next i            .SaveAs (ActiveWorkbook.Path + "/verbatims.doc")          .Close ' close the document      End With      wrdApp.Quit ' close the Word application      Set wrdDoc = Nothing      Set wrdApp = Nothing  End Function 

If you have any further questions and concerns, please don’t hesitate to ask.  

If the answer is helpful, please click "Accept Answer" and kindly upvote it. If you have extra questions about this answer, please click "Comment". 

Note: Please follow the steps in our documentation to enable e-mail notifications if you want to receive the related email notification for this thread.     

Hi @Lisa Cm, 

If the issue still persists on your end, there would be a workaround for you. You can try changing the file extension from .docx to .doc.

Please try it and let me know if the issue is resolved. Thank you for your valuable time and understanding.

If the answer is helpful, please click "Accept Answer" and kindly upvote it. If you have extra questions about this answer, please click "Comment". 

Note: Please follow the steps in our documentation to enable e-mail notifications if you want to receive the related email notification for this thread.