Macro Freezes

msquared99 · Apr 8, 2016

I have a macro that has been working for a while. For the last two months it has not been working. It pulls the data into the spreadsheet from Access and then just freezes. There are no errors, no nothing, just the little blue circle like it is doing something. But it just hangs there. Can someone help me to troubleshoot?

Code:

Sub RunParameterQuery()
 
'Step 1: Declare your variables
Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset
Dim i As Integer
 
'Step 2: Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase("C:Test\Access DB Test\M3 Database Export.accdb")

Set MyQueryDef = MyDatabase.QueryDefs("Commission Report")
 
'Step 3: Define the Parameters
With MyQueryDef
.Parameters("[Please enter a begin date]") = InputBox("Please enter a begin date")
.Parameters("[Please enter an end date]") = InputBox("Please enter an end date")
End With
 
'Step 4: Open the query
Set MyRecordset = MyQueryDef.OpenRecordset
 
'Step 5: Clear previous contents
Sheets("RawData").Select
ActiveSheet.Range("A1:Q1000000").ClearContents
 
'Step 6: Copy the recordset to Excel
ActiveSheet.Range("A2").CopyFromRecordset MyRecordset
 
'Step 7: Add column heading names to the spreadsheet
For i = 1 To MyRecordset.Fields.Count
ActiveSheet.Cells(1, i).Value = MyRecordset.Fields(i - 1).Name
Next i
 
'Part 2 Create Workbooks for Reps
  Dim WBO As Workbook 'original workbook
  Dim WBN As Workbook 'new workbook
  Dim WSO As Worksheet 'original worksheet
  Dim WSN As Worksheet 'new worksheet
  Dim r As Long
  Dim finalrow As Long
  
  Sheets("RawData").Activate

  Set WBO = ActiveWorkbook
  Set WSO = ActiveSheet
  
  Application.ScreenUpdating = False
  
  finalrow = WSO.Cells(Rows.Count, 1).End(xlUp).Row + 1
  
  Workbooks.Open Filename:="C:Test\Commission ID's.xls"
  WBO.Activate
  Application.Calculation = xlCalculationAutomatic
  WSO.Range("Q2").Select
  ActiveCell.FormulaR1C1 = _
  "=VLOOKUP(RC[-16],'[Commission ID''s.xls]Active Commissions'!R3C1:R50C5,5,0)"
  With WSO.Range("Q2")
  .AutoFill Destination:=Range("Q2:Q" & finalrow)
  End With
  
  WSO.Sort.SortFields.Clear
  WSO.Sort.SortFields.Add Key:=Range("Q2:Q" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
  xlSortNormal
  With WSO.Sort
  .SetRange Range("A1:Q" & finalrow)
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
  End With
  Columns("Q:Q").Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Range("A2").Select
'  On Error Resume Next
'  Columns("Q").SpecialCells(xlFormulas, xlErrors).EntireRow.Delete
'  On Error GoTo 0
  
  Cells.Find(What:="#N/A", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
  :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
  False, SearchFormat:=False).Activate
  Range(Selection, Selection.End(xlDown)).Select
  Selection.EntireRow.Delete
  
  Range("A2").Select
  
  LastReferral = Cells(2, 17)
  startRow = 2
  
  For r = 2 To finalrow
  ThisReferral = WSO.Cells(r, 17)
  If ThisReferral = LastReferral Then
  'do nothing
  
  Else
  'we have a new referral starting
  'copy all of the previous rows to a new workbook
  lastRow = r - 1
  RowCount = lastRow - startRow + 1
  
  'create a new workbook
  Set WBN = Workbooks.Add(template:=xlWBATWorksheet)
  Set WSN = WBN.Worksheets(1)
  
  'Setup the headings for the report
  WSN.Cells(1, 1).Value = LastReferral
  WSN.Range("A1:P1").Select
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlBottom
  .WrapText = False
  .MergeCells = True
  .Font.Bold = True
  End With
  
  WSN.Cells(2, 1).FormulaR1C1 = "=Today()-9"
  WSN.Range("A2:P2").Select
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlBottom
  .WrapText = False
  .MergeCells = True
  .Font.Bold = True
  .NumberFormat = "[$-409]mmmm-yy;@"
  End With
  WSN.Cells(2, 1).Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  
  WSN.Cells(3, 1).Value = "Monthly Commission Report"
  WSN.Range("A3:P3").Select
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlBottom
  .WrapText = False
  .MergeCells = True
  .Font.Bold = True
  End With
  
  WSN.Name = "M3"
  'Sheets.Add before:=Sheets(Sheets.Count)
  
  
  WSO.Range("A1:P1").Copy Destination:=WSN.Cells(5, 1)
  
  'copy all of the records for this referral
  WSO.Range(WSO.Cells(startRow, 1), WSO.Cells(lastRow, 16)).Copy Destination:=WSN.Cells(6, 1)
  
  ActiveWindow.Zoom = 80
  Columns("A:P").Select
  Columns("A:P").EntireColumn.AutoFit
  
  
  'StartRow = 6
  endRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
  
  'Cells(EndRow, 1).Value = "Total"
  'Cells(EndRow, 16).FormulaR1C1 = "=Sum(R[" & StartRow - EndRow & "]C:R[-1]C)"
  
  'This is new code*********************
  With ActiveSheet.PageSetup
  .PrintTitleRows = ""
  .PrintTitleColumns = ""
  End With
  
  ActiveSheet.PageSetup.PrintArea = ""
  
  With ActiveSheet.PageSetup
  .Orientation = xlLandscape
  .PaperSize = xlPaperLetter
  .FitToPagesWide = 1
  .FitToPagesTall = 1
  End With
  
  'NEW CODE to sort sheets. 6/29/15
  WSN.Range("A5:P" & endRow).Select
  WSN.Sort.SortFields.Clear
  Selection.Sort Key1:=Range("D5"), order1:=xlAscending, Key2:=Range("B5"), order2:=xlAscending, Header:=xlGuess, Orientation:=xlSortColumns
  
  WSN.Range("A5").Select
  Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(16), _
  Replace:=True, PageBreaks:=False, SummaryBelowData:=True
  
  WSN.Columns("P:P").Select
  Selection.NumberFormat = "#,##0.00_);[Red](#,##0.00)"
  WSN.Range("A2").Select
  With Selection
  .NumberFormat = "[$-409]mmmm-yy;@"
  End With
  
  WSN.Range("B6:B20000").Select
  Selection.NumberFormat = "0"
  WSN.Range("E6:E20000").Select
  Selection.NumberFormat = "mm/dd/yy;@"
  WSN.Range("H6:H20000").Select
  Selection.NumberFormat = "mm/dd/yy;@"
  WSN.Range("I6:I20000").Select
  Selection.NumberFormat = "mm/dd/yy;@"
  
  Sheets.Add
  Sheets("Sheet2").Select
  Sheets("Sheet2").Name = "Commission Summary"
  With Sheets
  Range("B1").Value = ("Total")
  Range("B1").Select
  Selection.HorizontalAlignment = xlCenter
  Selection.Font.Bold = True
  Range("A2").Value = ("M3")
  Range("A3").Value = ("IC")
  Range("A4").Value = ("B&I")
  Range("A5").Value = ("Time")
  Range("A6").Value = ("CFS")
  Range("A7").Value = ("Skylight")
  Range("A8").Value = ("Adjustments")
  Range("A9").Value = ("Bonus")
  Range("A10").Value = ("Total")
  Range("B10").Formula = "=SUM(B2:B9)"
  Range("B10").Select
  Selection.Style = "Currency"
  Selection.Font.Bold = True
  Columns("A:A").Select
  Selection.Font.Bold = True
  Columns("A:A").AutoFit
  Range("A1").Select
  End With
  
  FN = LastReferral & " " & Format(Date - 9, "mm-yy") & ".xlsx"
  FP = WBO.Path & Application.PathSeparator
  WBN.SaveAs Filename:=FP & FN
  WBN.Close SaveChanges:=Fales
  
  LastReferral = ThisReferral
  startRow = r
  End If
  Next r
  
  Call IC_Commissions
  
  Application.ScreenUpdating = True
  
  MsgBox ("Process is complete!")
 
End Sub

NARAYANK991 · Apr 9, 2016

Hi ,

Can you copy this code into your workbook , run it and observe the output which is printed in the Immediate window while the code is executing ?

There are some Debug.Print statements inserted in the code , and based on what is printed out , we can get an idea of where it is getting stuck.

Narayan

Code:

Sub RunParameterQuery()
'Step 1: Declare your variables
Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset
Dim i As Integer
'Step 2: Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase("C:Test\Access DB Test\M3 Database Export.accdb")

Set MyQueryDef = MyDatabase.QueryDefs("Commission Report")
'Step 3: Define the Parameters
With MyQueryDef
.Parameters("[Please enter a begin date]") = InputBox("Please enter a begin date")
.Parameters("[Please enter an end date]") = InputBox("Please enter an end date")
End With
'Step 4: Open the query
Set MyRecordset = MyQueryDef.OpenRecordset
'Step 5: Clear previous contents
Sheets("RawData").Select
ActiveSheet.Range("A1:Q1000000").ClearContents
'Step 6: Copy the recordset to Excel
ActiveSheet.Range("A2").CopyFromRecordset MyRecordset
'Step 7: Add column heading names to the spreadsheet
Debug.Print "Step 7"
For i = 1 To MyRecordset.Fields.Count
ActiveSheet.Cells(1, i).Value = MyRecordset.Fields(i - 1).Name
Next i
'Part 2 Create Workbooks for Reps
Dim WBO As Workbook 'original workbook
Dim WBN As Workbook 'new workbook
Dim WSO As Worksheet 'original worksheet
Dim WSN As Worksheet 'new worksheet
Dim r As Long
  Dim finalrow As Long
 
  Debug.Print "Step 8"
  Sheets("RawData").Activate

  Set WBO = ActiveWorkbook
  Set WSO = ActiveSheet
 
  Application.ScreenUpdating = False
 
  finalrow = WSO.Cells(Rows.Count, 1).End(xlUp).Row + 1
 
  Workbooks.Open Filename:="C:Test\Commission ID's.xls"
  WBO.Activate
  Application.Calculation = xlCalculationAutomatic
  WSO.Range("Q2").Select
  ActiveCell.FormulaR1C1 = _
  "=VLOOKUP(RC[-16],'[Commission ID''s.xls]Active Commissions'!R3C1:R50C5,5,0)"
  With WSO.Range("Q2")
  .AutoFill Destination:=Range("Q2:Q" & finalrow)
  End With
 
  Debug.Print "Starting Sort"
  WSO.Sort.SortFields.Clear
  WSO.Sort.SortFields.Add Key:=Range("Q2:Q" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
  xlSortNormal
  With WSO.Sort
  .SetRange Range("A1:Q" & finalrow)
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
  End With
 
  Debug.Print "Starting Copy + Paste"
  Columns("Q:Q").Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Range("A2").Select
'  On Error Resume Next
'  Columns("Q").SpecialCells(xlFormulas, xlErrors).EntireRow.Delete
'  On Error GoTo 0
  Cells.Find(What:="#N/A", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
  :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
  False, SearchFormat:=False).Activate
  Range(Selection, Selection.End(xlDown)).Select
  Selection.EntireRow.Delete
 
  Range("A2").Select
 
  LastReferral = Cells(2, 17)
  startRow = 2
 
  Debug.Print "Starting For ... Next loop"
  For r = 2 To finalrow
  ThisReferral = WSO.Cells(r, 17)
  If ThisReferral = LastReferral Then
  'do nothing
  Else
  'we have a new referral starting
'copy all of the previous rows to a new workbook
lastRow = r - 1
  RowCount = lastRow - startRow + 1
 
  'create a new workbook
Set WBN = Workbooks.Add(template:=xlWBATWorksheet)
  Set WSN = WBN.Worksheets(1)
 
  'Setup the headings for the report
WSN.Cells(1, 1).Value = LastReferral
  WSN.Range("A1:P1").Select
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlBottom
  .WrapText = False
  .MergeCells = True
  .Font.Bold = True
  End With
 
  WSN.Cells(2, 1).FormulaR1C1 = "=Today()-9"
  WSN.Range("A2:P2").Select
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlBottom
  .WrapText = False
  .MergeCells = True
  .Font.Bold = True
  .NumberFormat = "[$-409]mmmm-yy;@"
  End With
  WSN.Cells(2, 1).Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
  WSN.Cells(3, 1).Value = "Monthly Commission Report"
  WSN.Range("A3:P3").Select
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlBottom
  .WrapText = False
  .MergeCells = True
  .Font.Bold = True
  End With
 
  WSN.Name = "M3"
  'Sheets.Add before:=Sheets(Sheets.Count)
 
  WSO.Range("A1:P1").Copy Destination:=WSN.Cells(5, 1)
 
  'copy all of the records for this referral
WSO.Range(WSO.Cells(startRow, 1), WSO.Cells(lastRow, 16)).Copy Destination:=WSN.Cells(6, 1)
 
  ActiveWindow.Zoom = 80
  Columns("A:P").Select
  Columns("A:P").EntireColumn.AutoFit
 
 
  'StartRow = 6
endRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
 
  'Cells(EndRow, 1).Value = "Total"
'Cells(EndRow, 16).FormulaR1C1 = "=Sum(R[" & StartRow - EndRow & "]C:R[-1]C)"
  'This is new code*********************
With ActiveSheet.PageSetup
  .PrintTitleRows = ""
  .PrintTitleColumns = ""
  End With
 
  ActiveSheet.PageSetup.PrintArea = ""
 
  With ActiveSheet.PageSetup
  .Orientation = xlLandscape
  .PaperSize = xlPaperLetter
  .FitToPagesWide = 1
  .FitToPagesTall = 1
  End With
 
  Debug.Print "NEW CODE to sort sheets. 6/29/15"
WSN.Range("A5:P" & endRow).Select
  WSN.Sort.SortFields.Clear
  Selection.Sort Key1:=Range("D5"), order1:=xlAscending, Key2:=Range("B5"), order2:=xlAscending, Header:=xlGuess, Orientation:=xlSortColumns
 
  WSN.Range("A5").Select
  Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(16), _
  Replace:=True, PageBreaks:=False, SummaryBelowData:=True
 
  WSN.Columns("P:P").Select
  Selection.NumberFormat = "#,##0.00_);[Red](#,##0.00)"
  WSN.Range("A2").Select
  With Selection
  .NumberFormat = "[$-409]mmmm-yy;@"
  End With
 
  WSN.Range("B6:B20000").Select
  Selection.NumberFormat = "0"
  WSN.Range("E6:E20000").Select
  Selection.NumberFormat = "mm/dd/yy;@"
  WSN.Range("H6:H20000").Select
  Selection.NumberFormat = "mm/dd/yy;@"
  WSN.Range("I6:I20000").Select
  Selection.NumberFormat = "mm/dd/yy;@"
 
  Sheets.Add
  Sheets("Sheet2").Select
  Sheets("Sheet2").Name = "Commission Summary"
  With Sheets
  Range("B1").Value = ("Total")
  Range("B1").Select
  Selection.HorizontalAlignment = xlCenter
  Selection.Font.Bold = True
  Range("A2").Value = ("M3")
  Range("A3").Value = ("IC")
  Range("A4").Value = ("B&I")
  Range("A5").Value = ("Time")
  Range("A6").Value = ("CFS")
  Range("A7").Value = ("Skylight")
  Range("A8").Value = ("Adjustments")
  Range("A9").Value = ("Bonus")
  Range("A10").Value = ("Total")
  Range("B10").Formula = "=SUM(B2:B9)"
  Range("B10").Select
  Selection.Style = "Currency"
  Selection.Font.Bold = True
  Columns("A:A").Select
  Selection.Font.Bold = True
  Columns("A:A").AutoFit
  Range("A1").Select
  End With
 
  FN = LastReferral & " " & Format(Date - 9, "mm-yy") & ".xlsx"
  FP = WBO.Path & Application.PathSeparator
  WBN.SaveAs Filename:=FP & FN
  WBN.Close SaveChanges:=Fales
 
  LastReferral = ThisReferral
  startRow = r
  End If
  Next r
 
  Debug.Print "Last Stage"
  Call IC_Commissions
 
  Application.ScreenUpdating = True
 
  MsgBox ("Process is complete!")
End Sub

msquared99 · Apr 15, 2016

Hello Narayan.

Sorry it took me a while to reply. I had the flu and am just catching up.

I added the Debugs to the macro. The macro never makes it to the first Debug. Right after it pulls the data into the spreadsheet, it just hangs there with the blue circle. As a matter of fact, nothing shows in the Immediate or Locals windows.

Any ideas?

NARAYANK991 · Apr 16, 2016

Hi ,

Is the screen displaying the input boxes for entering the begin and end dates ?

Narayan

msquared99 · Apr 18, 2016

Yes. I am able to enter the dates. The data also pulls into the spreadsheet. Then, that is where it seems to hang-up.

NARAYANK991 · Apr 19, 2016

Hi ,

Which leaves us with Step 4 or Step 6 as the problem steps. I am excluding Step 5 , since it has to do only with activating a worksheet and clearing a range.

Can you put a breakpoint on this line of code :

Set MyRecordset = MyQueryDef.OpenRecordset

Setting a breakpoint on a line of code is done by placing the cursor on the line of code and pressing the F9 key.

Now , when you execute the macro by pressing the F5 key , program execution will stop when it comes to the line where a breakpoint has been inserted.

You are now automatically in Debug mode , and can check all the variables as well as execute statements in the Immediate window.

For example , you can enter the above line of code in the Immediate window , and see what happens. If the line of code executes and completes execution quickly , then you can enter the next line of code , after activating the worksheet tab RawData :

ActiveSheet.Range("A2").CopyFromRecordset MyRecordset

Narayan

msquared99 · Apr 19, 2016

Good morning.

I added the break and the macro ran like it is supposed to. I then added a break at Step 6. The macro was fine. So I added a break to Step 7. I did notice that the macro does pull in the data from Access, but it never pulls in the header names. So it is hanging between Step 6 and 7.

Mike

msquared99 · Apr 19, 2016

OK, I commented out Step 7 and the macro ran. So, how do I fix Step 7?

NARAYANK991 · Apr 20, 2016

Hi ,

You will have to do the debugging , step by step.

First , put a breakpoint at the following line :

Debug.Print"Step 7"

Run the macro and when it halts at the above line , start the debugging process by pressing F8 ; each press of this key will make the system execute the next line of code.

At each stage , you can display the intermediate values of variables by using the Immediate window ; for example , you can have the following entered in the Immediate window :

?MyRecordset.Fields.Count

and see what is displayed.

When you press the F8 key to step through the following section of code :

For i = 1 To MyRecordset.Fields.Count
ActiveSheet.Cells(1, i).Value = MyRecordset.Fields(i - 1).Name
Next i

you can enter :

?MyRecordset.Fields(i - 1).Name

and see what is displayed.

Narayan

Macro Freezes

msquared99

Member

NARAYANK991

Excel Ninja

msquared99

Member

NARAYANK991

Excel Ninja

msquared99

Member

NARAYANK991

Excel Ninja

msquared99

Member

msquared99

Member

NARAYANK991

Excel Ninja