Macros lagging and now crashing after working perfectly - can't find problem.

rdetreville · Jun 5, 2015

Hello,

I've been working night and day on an excel tool for the past two weeks and was one macro away from being finished when now Excel operates extremely slowly and eventually becomes unresponsive. I've tried to debug/step through, but can't seem to find the problem.

I don't know what else to do other than post my codes here. I'm very frustrated. If anyone is feeling charitable and bored and wouldn't mind looking through these codes, that would be great. My tool used to run all the way to the end but all of a sudden can barely get started. I'm sure I've not written these codes in the best form possible and maybe my codes make the computer run out of resources.

The codes start from button execution on the "DataScrubForm" user form. Next two modules contain the macros. The "DataScrub" module has all the macros for my data cleanup. The "ReportBuild" module has codes that build an automated report tool that allows the user to work with the data that the original file generated. I'll color code below: "DataScrubForm" macro. "DataScrub" module. And "ReportBuild" module.

If anyone could help me figure out what is going on here, I would be forever thankful. Perhaps the system doesn't like that I "Call" so many macros back-to-back? Perhaps I need to do something with updating or event enabling or calcmode. I know I use a lot of "selects".

The code was working just fine until I added the last four macros in the ReportBuild module. And now it doesn't work/takes forever/hangs up without ever really giving an error.

DataScrubForm Macro:

Code:

Private Sub CommandButton1_Click()
MsgBox ("Please wait momentarily as your Tracker data is scrubbed.  You will be prompted if any input is needed.")
Sheets("Report - RAM").Select
Call columncolor

Dim reportmonth As String
reportmonth = ComboBox1.Value
Sheets("Report - RAM").Range("A260").Value = reportmonth

With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Call scrub2

    Call monthbyebye
    Call removeemptytracker
    Call sizeup
    Call addprojectnamecolumn
    'add in removal here!
        
    Call govert
    
    
    
    Sheets("RAM Data").Range("A1").Select
  
   Sheets("RAM Data").Name = "RAM Data - " & Format(Date, "mm.dd.yyyy")
   
   Application.DisplayAlerts = False
  Sheets("Report - RAM").Delete
Application.DisplayAlerts = True

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
  Beep
  MsgBox "Your data has been properly scrubbed and is now ready for report generation!" & vbNewLine & vbNewLine & "The latest Project Tracker file information will now be pulled from the SUS-PAR SharePoint Library and will be used to provide information in your report.  Please press ok to continue.", , "Success!"
 
   Call updateSPdata
    
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    
     
     
     With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With






End Sub


Private Sub CommandButton10_Click()
Dim reportmonth As String
reportmonth = ComboBox1.Value
Sheets("Report - RAM").Range("A260").Value = reportmonth

With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Call scrub2
    Call monthbyebye
    Call removeemptytracker
    Call sizeup
    Call addprojectnamecolumn
    Call govert
    
     With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With


End Sub

Private Sub UserForm_Initialize()
ComboBox1.AddItem "May-2015"
ComboBox1.AddItem "June-2015"
ComboBox1.AddItem "July-2015"
ComboBox1.AddItem "August-2015"
ComboBox1.AddItem "September-2015"
ComboBox1.AddItem "October-2015"
ComboBox1.AddItem "November-2015"
ComboBox1.AddItem "December-2015"
ComboBox1.AddItem "January-2016"
ComboBox1.AddItem "February-2016"
ComboBox1.AddItem "March-2016"
ComboBox1.AddItem "April-2016"
ComboBox1.AddItem "May-2016"
ComboBox1.AddItem "June-2016"
ComboBox1.AddItem "July-2016"
ComboBox1.AddItem "August-2016"
ComboBox1.AddItem "September-2016"
ComboBox1.AddItem "October-2016"
ComboBox1.AddItem "November-2016"
ComboBox1.AddItem "December-2016"
ComboBox1.AddItem "January-2017"
ComboBox1.AddItem "February-2017"
ComboBox1.AddItem "March-2017"
ComboBox1.AddItem "April-2017"
ComboBox1.AddItem "May-2017"
ComboBox1.AddItem "June-2017"
ComboBox1.AddItem "July-2017"
ComboBox1.AddItem "August-2017"
ComboBox1.AddItem "September-2017"
ComboBox1.AddItem "October-2017"
ComboBox1.AddItem "November-2017"
ComboBox1.AddItem "December-2017"
ComboBox1.AddItem "January-2018"
ComboBox1.AddItem "February-2018"
ComboBox1.AddItem "March-2018"
ComboBox1.AddItem "April-2018"
ComboBox1.AddItem "May-2018"
ComboBox1.AddItem "June-2018"
ComboBox1.AddItem "July-2018"
ComboBox1.AddItem "August-2018"
ComboBox1.AddItem "September-2018"
ComboBox1.AddItem "October-2018"
ComboBox1.AddItem "November-2018"
ComboBox1.AddItem "December-2018"
End Sub

"DataScrub" module and macros within:

Code:

Sub columncolor()
  
   With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
   Set ws = Sheets("Report - RAM")
 ws.Copy After:=Sheets("SP Status - RAM")
 Set wsNew = Sheets(Sheets("SP Status - RAM").Index + 1)
 wsNew.Name = "Archive_RAM Pull"
  
 Sheets("Report - RAM").Select
  
  Application.FindFormat.Clear
    Application.ReplaceFormat.Clear
  With ActiveSheet
  Application.FindFormat.Clear
    Application.ReplaceFormat.Clear
    Cells.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
         Application.FindFormat.Clear
    Application.ReplaceFormat.Clear
    Cells.Replace What:="#REF!", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Rows("2:2").Delete
Rows("2:2").Delete

Rows("2:2").Select
    With Selection.Font
    .ColorIndex = 1
    End With
    Rows("2:2").Select
     Application.FindFormat.Clear
    Application.ReplaceFormat.Clear
     Application.ReplaceFormat.Font.ColorIndex = 3
    
   Selection.Replace What:="Team Member", Replacement:="Team Member", LookAt _
        :=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
     
        
        Rows("1:1").Select
    Selection.Cut
    
    Rows("260:260").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    Call color2
    Range("A1").Select
    
    With Range("A1:IUA250")
.FormatConditions.Delete
 .FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
        Formula1:="=40909", Formula2:="=43465"
 .FormatConditions(1).NumberFormat = "mmm-yyyy"

End With
    
    
    Call deleteblahcolumns
    Range("A1").Select
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
          End With
 End Sub
 
 Sub deleteblahcolumns()
 Dim lColumn As Long
Dim iCntr As Long
lColumn = 10000
For iCntr = lColumn To 1 Step -1
    If Cells(1, iCntr).Font.ColorIndex = 1 Then Columns(iCntr).Delete
    
Next
 End Sub
     
Sub color2()
 Dim rng As Range
Dim row As Range
Dim cell As Range

Set rng = Range("A1:IUA1")

For Each row In rng.Rows
  For Each cell In row.Cells
    If cell.Value >= 40909 And cell.Value <= 43465 Then cell.Font.ColorIndex = 5
    
  Next cell
Next row
 End Sub


Sub turngreen()
'Asks for phrase to find then finds and marks within each cell everywhere it is found.
   Application.FindFormat.Clear
    Application.ReplaceFormat.Clear
  Dim rCell As Range, sToFind As String, iSeek As Long
  sToFind = "Team Member"
 
  For Each rCell In Range("A1:IUA1") 'can be any range or explicit (i.e. Range("A1:G6") instead of Selection)
    iSeek = InStr(1, rCell.Value, sToFind)
    Do While iSeek > 0
      With rCell.Characters(iSeek, Len(sToFind)).Font.ColorIndex = 3
        
      End With
      iSeek = InStr(iSeek + 1, rCell.Value, sToFind)
    Loop
  Next

End Sub

Sub scrub2()
Dim rng As Range
Dim row As Range
Dim cell As Range

Set rng = Range("A1:IUA1")

For Each row In rng.Rows
  For Each cell In row.Cells
    If cell.Value < Range("A260").Value Then cell.Font.ColorIndex = 6
    
  Next cell
Next row
End Sub
Sub monthbyebye()
 Dim lColumn As Long
Dim iCntr As Long
lColumn = 10000
For iCntr = lColumn To 1 Step -1
    If Cells(1, iCntr).Font.ColorIndex = 6 Then Columns(iCntr).Delete
    
Next
End Sub

Sub removeemptytracker()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim deleteme As String


Set rng = Range("A1:JUA1")

For Each row In rng.Rows
  For Each cell In row.Cells
    If cell.Value = "Team Member" And cell.Offset(, 1).Value = "Team Member" Then cell.Font.ColorIndex = 6
    
  Next cell
Next row
Call monthbyebye
End Sub


Sub addprojectnamecolumn()

Dim lColumn As Long
Dim iCntr As Long
lColumn = 10000
For iCntr = lColumn To 1 Step -1
    
    If Cells(1, iCntr).Value = "Team Member" Then Cells(1, iCntr).EntireColumn.Insert
    
    Next
  
  'use End(xlToLeft) to determine Last Column with Data, in one row (row number 2)
 
Dim lastcolumn As Integer

lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).column

 Dim lColumn2 As Long
Dim iCntr2 As Long
lColumn2 = lastcolumn
For iCntr2 = lColumn2 To 1 Step -1
    
    If Cells(1, iCntr2).Value = "" Then Cells(1, iCntr2).Value = "Tracker Name"
    
    Next
Call populatecolumnname2

End Sub

         


Sub populatecolumnname2()

Dim lColumn As Long
Dim iCntr As Long
lColumn = 10000
For iCntr = lColumn To 1 Step -1
    
    If Cells(1, iCntr).Value = "Tracker Name" Then Cells(1, iCntr).Font.ColorIndex = 7
    
    Next
    Call populatecolumnname3
End Sub


Sub populatecolumnname3()

Dim lColumn As Long
Dim iCntr As Long
lColumn = 10000
For iCntr = lColumn To 1 Step -1
    
    If Cells(1, iCntr).Value = "Team Member" Then Cells(1, iCntr).End(xlDown).Offset(0, -1).Value = Cells(1, iCntr).Offset(258, 0).Value
 
    Next
  Call populatecolumnname4
End Sub




Sub populatecolumnname4()

Dim lColumn As Long
Dim iCntr As Long
Dim ahhh As String



lColumn = 10000
For iCntr = lColumn To 1 Step -1
    
    If Cells(1, iCntr).Value = "Tracker Name" Then Range(Cells(1, iCntr).Offset(1), (Cells(1, iCntr).End(xlDown))) = Cells(1, iCntr).End(xlDown).Value
       
  
   
Next
End Sub

Sub govert()

Dim lColumn As Long
Dim iCntr As Long
lColumn = 10000
For iCntr = lColumn To 1 Step -1
    
    If Cells(1, iCntr).Value = "Tracker Name" Then Cells(1, iCntr).EntireColumn.Insert
    
    Next
  
Call govert22
 
End Sub
Sub govert2()
Dim Found As Range
    Dim FirstFound As String
    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    Sheets.Add(After:=ActiveSheet).Name = "RAM Data"
    
    Set Found = ws.Rows(1).Find("Tracker Name", , , xlWhole, 1, 1, 0)
    
    If Not Found Is Nothing Then
        FirstFound = Found.Address
        Found.CurrentRegion.Copy Destination:=Range("A1")
        Do
            Set Found = ws.Rows(1).FindNext(After:=Found)
            Found.CurrentRegion.Offset(1).Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1)
        Loop Until Found.Address = FirstFound
    Else
        MsgBox "Cannot find header ""Tracker Name""."
    End If
    
    Application.ScreenUpdating = True
  
    Call blankstaffremoval
End Sub

Sub govert22()

    
   Dim Found As Range
    Dim FirstFound As String
    Dim ws As Worksheet
    Dim rngHeaders As Range
    
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    Sheets.Add(After:=ActiveSheet).Name = "RAM Data"
    
    Set Found = ws.Rows(1).Find("Tracker Name", , , xlWhole, 1, 1, 0)
    
    If Not Found Is Nothing Then
        FirstFound = Found.Address
        Set rngHeaders = Found
        Do
            With Found.CurrentRegion
                .Offset(1).Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(4)
                If rngHeaders.Count < .Rows(1).Cells.Count Then Set rngHeaders = .Rows(1).Cells
            End With
            Set Found = ws.Rows(1).FindNext(After:=Found)
        Loop Until Found.Address = FirstFound
        rngHeaders.Copy Destination:=Range("A1")
    Else
        MsgBox "Cannot find header ""Tracker Name""."
    End If
    
    Application.ScreenUpdating = True
 
    
   Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    Call blankstaffremoval
    
End Sub
Sub govert222()
 Dim Found As Range
    Dim FirstFound As String
    Dim ws As Worksheet
    Dim rngHeaders As Range
    
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
        Sheets.Add(After:=ActiveSheet).Name = "RAM Data"
    
    Set Found = ws.Rows(1).Find("Tracker Name", , , xlWhole, 1, 1, 0)
    
    If Not Found Is Nothing Then
        FirstFound = Found.Address
        Set rngHeaders = Found
        Do
            With Found.CurrentRegion
                Range("A" & Rows.Count).End(xlUp).Offset(1).Rows("1:100").ClearContents
                .Offset(1).Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1)
                If rngHeaders.Count < .Rows(1).Cells.Count Then Set rngHeaders = .Rows(1).Cells
            End With
            Set Found = ws.Rows(1).FindNext(After:=Found)
        Loop Until Found.Address = FirstFound
        rngHeaders.Copy Destination:=Range("A1")
    Else
        MsgBox "Cannot find header ""Tracker Name""."
    End If
    
    Application.ScreenUpdating = True
      Call blankstaffremoval
End Sub

Sub blankstaffremoval()
    Dim ws As Worksheet
    Dim lRow As Long
    Dim StrSearch As String
    

    '~~> Set this to the relevant worksheet
    'Set ws = ThisWorkbook.Sheets("test")
    Set ws = ActiveWorkbook.Worksheets(2)

    '~~> Search Text
    StrSearch = "staff"

    With ws
        '~~> Remove any filters
        .AutoFilterMode = False

        lRow = .Range("B" & .Rows.Count).End(xlUp).row
On Error Resume Next
        With .Range("B1:B" & lRow)
            .AutoFilter Field:=1, Criteria1:="=*" & StrSearch & "*"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With
   
    Call morerowremove
    
End Sub

Sub morerowremove()
    Dim ws As Worksheet
    Dim lRow As Long
    Dim StrSearch As String


   Set ws = ActiveWorkbook.Worksheets(2)

    '~~> Search Text
    StrSearch = "Ram "

    With ws
        '~~> Remove any filters
        .AutoFilterMode = False

        lRow = .Range("B" & .Rows.Count).End(xlUp).row
On Error Resume Next
        With .Range("B1:B" & lRow)
            .AutoFilter Field:=1, Criteria1:="=*" & StrSearch & "*"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With
Call morerowremove2

End Sub

Sub morerowremove2()
    Dim ws As Worksheet
    Dim lRow As Long
    Dim StrSearch As String


   Set ws = ActiveWorkbook.Worksheets(2)

    '~~> Search Text
   ' StrSearch = "0"

    With ws
        '~~> Remove any filters
        .AutoFilterMode = False

        lRow = .Range("B" & .Rows.Count).End(xlUp).row

        With .Range("B1:B" & lRow)
            .AutoFilter Field:=1, Criteria1:="=0"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With
Call morerowremove3

End Sub
Sub morerowremove3()


    Dim ws As Worksheet
    Dim lRow As Long
    Dim StrSearch As String


   Set ws = ActiveWorkbook.Worksheets(2)

    '~~> Search Text
    StrSearch = "CATI:"

    With ws
        '~~> Remove any filters
        .AutoFilterMode = False

        lRow = .Range("B" & .Rows.Count).End(xlUp).row
On Error Resume Next
        With .Range("B1:B" & lRow)
            .AutoFilter Field:=1, Criteria1:="=*" & StrSearch & "*"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With
    Call finalprep
    End Sub
    


Sub finalprep()
Dim SelRange As Range


     Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    
    Set SelRange = Selection
    
   ' MsgBox Selection.Address(ReferenceStyle:=xlA1, _
                       '    RowAbsolute:=False, ColumnAbsolute:=False)
                           
    ActiveWorkbook.Worksheets(2).Range(SelRange.Address).Replace _
 What:="", Replacement:="0", _
 SearchOrder:=xlByColumns, MatchCase:=False
    Call deleteemptypeeps1
   

End Sub

Sub deleteemptypeeps1()


        
ActiveWorkbook.Worksheets(2).Range("AT2").Formula = "=sum(A2:AN2)"

Set SourceRange = ActiveWorkbook.Worksheets(2).Range("AT2")
Set fillRange = ActiveWorkbook.Worksheets(2).Range("AT2:AT10000")
SourceRange.AutoFill Destination:=fillRange

        Calculate
        
       
        Columns("AT:AT").Select
       Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        
        Dim ws As Worksheet
    Dim lRow As Long
    Dim StrSearch As String


   Set ws = ActiveWorkbook.Worksheets(2)

    '~~> Search Text
   ' StrSearch = "0"

    With ws
        '~~> Remove any filters
        .AutoFilterMode = False

        lRow = .Range("AT" & .Rows.Count).End(xlUp).row

        With .Range("AT1:AT" & lRow)
            .AutoFilter Field:=1, Criteria1:="0"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With
    
    Columns("AT").EntireColumn.Delete
Call deleteemptypeeps2
End Sub


Sub deleteemptypeeps2()


        
ActiveWorkbook.Worksheets(2).Range("C1200").Formula = "=sum(C2:C1199)"

Set SourceRange = ActiveWorkbook.Worksheets(2).Range("C1200")
Set fillRange = ActiveWorkbook.Worksheets(2).Range("C1200:AN1200")
SourceRange.AutoFill Destination:=fillRange

        
       Calculate
       
        Rows("1200:1200").Select
       Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
      
       Set r = ActiveSheet.UsedRange.Resize(1)

LC = r(r.Count).column

For x = LC To 1 Step -1

    If Cells(1200, x).Value = "0" Then
        Columns(x).EntireColumn.Delete
    End If
Next x
Rows(1200).EntireRow.Delete
End Sub


Sub updateSPdata()
ThisWorkbook.Sheets("CurrentSharePointTrackerInfo").Copy before:=ActiveWorkbook.Sheets(1)
ActiveWorkbook.RefreshAll
ActiveWorkbook.Worksheets(2).Select

Dim lColumn As Long
Dim iCntr As Long
lColumn = 10000
For iCntr = lColumn To 1 Step -1
    
    If Cells(1, iCntr).Value = "Team Member" Then Cells(1, iCntr).EntireColumn.Insert
    
    Next
    
    Range("B1").Value = "Tracker File Name"
    ActiveWorkbook.Worksheets(2).Range("B2").Formula = "=TRIM(RIGHT(SUBSTITUTE(A2,""\"",REPT("" "",255)),255))"
ActiveWorkbook.Worksheets(2).Range("B2").Select
Selection.AutoFill Destination:=Range("B2:B" & Range("C" & Rows.Count).End(xlUp).row)
Calculate
ActiveWorkbook.Worksheets(2).Columns("B:B").Copy
    ActiveWorkbook.Worksheets(2).Columns("B:B").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Call updateSPdata2
End Sub
Sub updateSPdata2()
Range("A1").EntireColumn.Insert
Range("A1").EntireColumn.Insert
Range("A1").EntireColumn.Insert
      Range("A1").EntireColumn.Insert
    Range("A1").EntireColumn.Insert
    Range("A1").EntireColumn.Insert
     Range("A1").EntireColumn.Insert
    Range("A1").Value = "Project Number"
       Range("B1").Value = "Project Name"
       Range("C1").Value = "PM"
       Range("D1").Value = "PIC"
            Range("E1").Value = "ProCo"
              Range("F1").Value = "Last PM Projections Update"
    Range("G1").Value = "Days since PM update"

ActiveWorkbook.Worksheets(2).Range("A2").Formula = "=VLOOKUP($I2,CurrentSharePointTrackerInfo!$B:$T,3,FALSE)"
ActiveWorkbook.Worksheets(2).Range("B2").Formula = "=VLOOKUP($I2,CurrentSharePointTrackerInfo!$B:$T,2,FALSE)"
ActiveWorkbook.Worksheets(2).Range("C2").Formula = "=VLOOKUP($I2,CurrentSharePointTrackerInfo!$B:$T,4,FALSE)"
ActiveWorkbook.Worksheets(2).Range("D2").Formula = "=VLOOKUP($I2,CurrentSharePointTrackerInfo!$B:$T,6,FALSE)"
ActiveWorkbook.Worksheets(2).Range("E2").Formula = "=VLOOKUP($I2,CurrentSharePointTrackerInfo!$B:$T,5,FALSE)"
ActiveWorkbook.Worksheets(2).Range("F2").Formula = "=VLOOKUP($I2,CurrentSharePointTrackerInfo!$B:$T,8,FALSE)"
ActiveWorkbook.Worksheets(2).Range("G2").Formula = "=VLOOKUP($I2,CurrentSharePointTrackerInfo!$B:$T,9,FALSE)"

 ActiveWorkbook.Worksheets(2).Range("A2:G2").Select
    Selection.AutoFill Destination:=Range("A2:G" & Range("H" & Rows.Count).End(xlUp).row)
    Calculate
    ActiveWorkbook.Worksheets(2).Columns("A:G").Copy
     ActiveWorkbook.Worksheets(2).Columns("A:G").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


ActiveWorkbook.Worksheets(2).Columns("E:E").Select
    Application.ReplaceFormat.Clear
       Selection.Replace What:="#??", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


Cells.HorizontalAlignment = xlLeft

Columns.AutoFit
Range("H1").EntireColumn.Delete
Range("A1").Select
Columns("F:F").NumberFormat = "m/d/yyyy"
 
 ThisWorkbook.Sheets("Names").Copy before:=ActiveWorkbook.Sheets(3)
                    
      



DataScrubForm.Hide
With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
Beep
MsgBox "Your RAM information has been updated and aligned with the latest data from the SUS-PAR SharePoint Library." & vbNewLine & vbNewLine & "Your information is now report ready!", , "Success!"
MsgBox "We will now need the latest RevRec report to compare against your Project Tracker report.  Please locate the newest RevRec report and place it somewhere on your local drive." & vbNewLine & vbNewLine & "You will now select this RevRec file.", , "Revenue Recognition Comparison"

Call revrec
End Sub

"ReportBuild" module and macros within:

Code:

Sub revrec()

Dim wbk1 As Workbook, wbk2 As Workbook

fileStr = Application.GetOpenFilename()

Set wbk1 = ActiveWorkbook
Set wbk2 = Workbooks.Add(fileStr)

wbk2.Sheets("Sheet1").Copy After:=wbk1.Sheets(2)
wbk2.Close

wbk1.Sheets("Sheet1").Name = "RevRec"


wbk1.Sheets(2).Move before:=wbk1.Sheets(1)
wbk1.Sheets(3).Move before:=wbk1.Sheets(2)

Range("A1").EntireRow.Insert
With Range("A1")
.Value = "Highlighted Cells Below Currently have a tracker on SharePoint."
.Font.ColorIndex = 3
.WrapText = True

End With

 Range("B1").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "MENU!A1", TextToDisplay:="Return to Main Report Menu"
              
    With Selection.Font
        .Name = "Verdana"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleSingle
        .ThemeColor = xlThemeColorHyperlink
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    
    
 ActiveSheet.ListObjects("Table_Database6.accdb").Range.AutoFilter Field:=5, _
        Criteria1:="226"
        Calculate
        
        ActiveSheet.ListObjects("Table_Database6.accdb").Range.AutoFilter Field:=7, _
        Criteria1:="Active"
        Calculate
         
         
         ActiveWorkbook.Worksheets(1).Select
         
          Range("J1").EntireColumn.Insert
          Range("J1").EntireColumn.Insert
         
          Range("J1").Value = "District"
       Range("K1").Value = "Unit"
        Rows("1:1").Font.Bold = True
       
       ActiveWorkbook.Worksheets(1).Range("J2").Formula = "=VLOOKUP(I2,Names!$A:$C,2,FALSE)"
       ActiveWorkbook.Worksheets(1).Range("K2").Formula = "=VLOOKUP(I2,Names!$A:$C,3,FALSE)"
       
       ActiveWorkbook.Worksheets(1).Range("J2:K2").Select
    Selection.AutoFill Destination:=Range("J2:K" & Range("L" & Rows.Count).End(xlUp).row)
    Calculate
    ActiveWorkbook.Worksheets(1).Columns("J:K").Copy
     ActiveWorkbook.Worksheets(1).Columns("J:K").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
             
            Range("L1").EntireColumn.Insert
              Range("L1").Value = "Total Hours"
             ActiveWorkbook.Worksheets(1).Range("L2").Formula = "=SUM($M2:$BU2)"
             ActiveWorkbook.Worksheets(1).Range("L2").Select
    Selection.AutoFill Destination:=Range("L2:L" & Range("M" & Rows.Count).End(xlUp).row)
    Calculate
    ActiveWorkbook.Worksheets(1).Columns("L:L").Copy
     ActiveWorkbook.Worksheets(1).Columns("L:L").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
                          
             Dim tbl As ListObject
    Dim rng As Range

Range("A1").CurrentRegion.Select
    Set rng = ActiveSheet.Range(Selection.Address)
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
    tbl.Name = "MainTable"
             
         ThisWorkbook.Sheets("Menu").Copy before:=ActiveWorkbook.Sheets(6)
         ActiveWorkbook.Sheets("Menu").Move before:=ActiveWorkbook.Sheets(1)
Call reportbuild2
End Sub
Sub reportbuild2()
   Dim busy As Range
   
   ActiveWorkbook.Worksheets(2).Select
Range("MainTable[[#Headers],[Team Member]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("MENU").Select
    Range("A2001").Select
    ActiveSheet.Paste
   ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[Total Hours]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("B2001").Select
    ActiveSheet.Paste
   Dim tbl As ListObject
    Dim rng As Range

Range("B2001").CurrentRegion.Select
    Set rng = ActiveSheet.Range(Selection.Address)
   Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
    tbl.Name = "TableBusy"
   
   
    Range("TableBusy[#All]").Select
    ActiveSheet.Range("TableBusy[#All]").RemoveDuplicates Columns:=1, Header:= _
        xlYes
        
         ActiveWorkbook.Worksheets("MENU").ListObjects("TableBusy").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("MENU").ListObjects("TableBusy").Sort.SortFields.Add _
        Key:=Range("TableBusy[[#All],[Total Hours]]"), SortOn:=xlSortOnValues, _
        Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("MENU").ListObjects("TableBusy").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        Call reportbuild3
        End Sub

Sub reportbuild3()
   Dim busy As Range
   
   ActiveWorkbook.Worksheets(2).Select
Range("MainTable[[#Headers],[Team Member]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("MENU").Select
    Range("A3001").Select
    ActiveSheet.Paste
   ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[Total Hours]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("B3001").Select
    ActiveSheet.Paste
   Dim tbl As ListObject
    Dim rng As Range

Range("B3001").CurrentRegion.Select
    Set rng = ActiveSheet.Range(Selection.Address)
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
    tbl.Name = "TableNotBusy"
   
   
    Range("TableBusy[#All]").Select
    ActiveSheet.Range("TableNotBusy[#All]").RemoveDuplicates Columns:=1, Header:= _
        xlYes
        
         ActiveWorkbook.Worksheets("MENU").ListObjects("TableNotBusy").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("MENU").ListObjects("TableNotBusy").Sort.SortFields.Add _
        Key:=Range("TableNotBusy[[#All],[Total Hours]]"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("MENU").ListObjects("TableNotBusy").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        Call reportbuild4
        End Sub
        
        Sub reportbuild4()
   Dim busy As Range
   
   ActiveWorkbook.Worksheets(2).Select
Range("MainTable[[#Headers],[Tracker File Name]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("MENU").Select
    Range("A4001").Select
    ActiveSheet.Paste
   ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[PM]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("B4001").Select
    ActiveSheet.Paste
    ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[Last PM Projections Update]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("C4001").Select
    ActiveSheet.Paste
    ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[Days since PM update]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("D4001").Select
    ActiveSheet.Paste
                  
    
   Dim tbl As ListObject
    Dim rng As Range

Range("A4001").CurrentRegion.Select
    Set rng = ActiveSheet.Range(Selection.Address)
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
    tbl.Name = "TablePMUpdate"
   
   
    Range("TablePMUpdate[#All]").Select
    ActiveSheet.Range("TablePMUpdate[#All]").RemoveDuplicates Columns:=1, Header:= _
        xlYes
        
         ActiveWorkbook.Worksheets("MENU").ListObjects("TablePMUpdate").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("MENU").ListObjects("TablePMUpdate").Sort.SortFields.Add _
        Key:=Range("TablePMUpdate[[#All],[Last PM Projections Update]]"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("MENU").ListObjects("TablePMUpdate").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        
        
Columns("A").ColumnWidth = 29
Columns("B:AD").ColumnWidth = 6
       Call finalformatting
        End Sub
Sub finalformatting()
 Sheets("CurrentSharePointTrackerInfo").Select
 Range("A1").EntireRow.Insert
     Range("A1").Select
    ActiveCell.FormulaR1C1 = _
        "Click on a Tracker file name or PM folder name below to open that file or folder."
   
    Range("A1").Select
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Verdana"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    
    Range("D1").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "MENU!A1", TextToDisplay:="Return to Main Report Menu"
              
    With Selection.Font
        .Name = "Verdana"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleSingle
        .ThemeColor = xlThemeColorHyperlink
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    
    Rows("1:1").EntireRow.AutoFit
    ActiveWorkbook.Worksheets(6).Visible = False
    ActiveWorkbook.Worksheets(7).Visible = False
    
  
  Call movecodes
End Sub


Sub updatemenudata()

Dim trackeramount As String
 ActiveWorkbook.Worksheets(1).Select
Range("A4002").Select
    Range(Selection, Selection.End(xlDown)).Select
    trackeramount = Selection.Count
    
 ActiveWorkbook.Worksheets(3).Range("B1000").Formula = "=SUBTOTAL(3,B2:B998)-1"

    
Sheets("MENU").Shapes("datebox").TextFrame.Characters.Text = ActiveWorkbook.Worksheets(2).Range("M1").Value
Sheets("MENU").Shapes("trackcount").TextFrame.Characters.Text = "From Trackers: " & trackeramount


Sheets("MENU").Shapes("revcount").TextFrame.Characters.Text = "From RevRec: " & ActiveWorkbook.Worksheets(3).Range("B1000").Value

 ActiveWorkbook.Worksheets(1).Range("B474").Formula = "=COUNTIF(B101:B473,"">160"")-1"
 
Sheets("MENU").Shapes("busybox").TextFrame.Characters.Text = ActiveWorkbook.Worksheets(1).Range("B474").Value

 
 Call reportready

End Sub


Sub movecodes()
Dim vbComp As Object

str_tmppath = Environ("temp")
Workbooks("SUS-PAR Project Tracker Projections Reporting Tool_development.xlam").VBProject.VBComponents("CodeMove").Export (tmppath & "CodeMove.bas")
ActiveWorkbook.VBProject.VBComponents.Import (tmppath & "CodeMove.bas")
Call nextreportupdate
End Sub

Sub nextreportupdate()
ActiveWorkbook.Worksheets(1).Select
ActiveSheet.PivotTables("OverallRAM").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
        
        ActiveSheet.PivotTables("UniDis").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
        
        ActiveSheet.PivotTables("DisUni").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
        
          ActiveSheet.PivotTables("PivotDis").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
          
          ActiveSheet.PivotTables("PivotUn").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
        
        
        Dim PT As PivotTable, PTField As PivotField
Set PT = ActiveWorkbook.Worksheets(1).PivotTables("PivotDis")
With PT
    .ManualUpdate = True
    For Each PTField In .DataFields
        PTField.Orientation = xlHidden
    Next PTField
    .ManualUpdate = False
End With
Set PT = Nothing

  Dim PT As PivotTable, PTField As PivotField
Set PT = ActiveWorkbook.Worksheets(1).PivotTables("PivotUn")
With PT
    .ManualUpdate = True
    For Each PTField In .DataFields
        PTField.Orientation = xlHidden
    Next PTField
    .ManualUpdate = False
End With
Set PT = Nothing
        
        
          ActiveWorkbook.Worksheets(1).PivotTables("PivotDis").PivotFields("District").Orientation = _
        xlHidden
    With ActiveWorkbook.Worksheets(1).PivotTables("PivotDis").PivotFields("District")
        .Orientation = xlRowField
        .Position = 1
        
         ActiveWorkbook.Worksheets(1).PivotTables("PivotUn").PivotFields("Unit").Orientation = _
        xlHidden
    With ActiveWorkbook.Worksheets(1).PivotTables("PivotUn").PivotFields("Unit")
        .Orientation = xlRowField
        .Position = 1
        
                        
        Dim currentdate As String
currentdate = ActiveWorkbook.Worksheets(2).Range("M1").Value
 
 ActiveWorkbook.Worksheets(1).PivotTables("PivotDis").AddDataField ActiveSheet.PivotTables( _
        "PivotDis").PivotFields(currentdate), "Total Hours - " & currentdate, xlSum
        
        ActiveWorkbook.Worksheets(1).PivotTables("PivotDis").PivotFields("District").AutoSort _
        xlDescending, "Total Hours - " & currentdate, ActiveSheet.PivotTables("PivotDis"). _
        PivotColumnAxis.PivotLines(1), 1
        
        
        ActiveWorkbook.Worksheets(1).PivotTables("PivotUn").AddDataField ActiveSheet.PivotTables( _
        "PivotUn").PivotFields(currentdate), "Total Hours - " & currentdate, xlSum
        
        ActiveWorkbook.Worksheets(1).PivotTables("PivotUn").PivotFields("Unit").AutoSort _
        xlDescending, "Total Hours - " & currentdate, ActiveSheet.PivotTables("PivotUn"). _
        PivotColumnAxis.PivotLines(1), 1

                                        
               ActiveWorkbook.Worksheets(1).Range("CU1:DA1").Columns.AutoFit
        
        
        Call makered
End Sub
Sub makered()
 ActiveSheet.PivotTables("OverallRAM").PivotSelect "", xlDataOnly, True
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=160"
    Selection.FormatConditions(1).Font.Color = -16776961
    Selection.FormatConditions(1).Font.Bold = True
        
     ActiveSheet.PivotTables("UniDis").PivotSelect "", xlDataOnly, True
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=160"
    Selection.FormatConditions(1).Font.Color = -16776961
     Selection.FormatConditions(1).Font.Bold = True
    
     ActiveSheet.PivotTables("DisUni").PivotSelect "", xlDataOnly, True
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=160"
    Selection.FormatConditions(1).Font.Color = -16776961
     Selection.FormatConditions(1).Font.Bold = True
   
    
    Call updatemenudata
    
End Sub

Sub reportready()
ThisWorkbook.RefreshAll
  Application.GoTo Reference:=Sheets("Menu").Range("a1"), Scroll:=True
End Sub

rdetreville · Jun 5, 2015

I finally got Excel to show me the VB error for a split second before it crashes:

I will research. I think this has to do with my second-to-last macro:

Code:

       Call makered
End Sub
Sub makered()
 ActiveSheet.PivotTables("OverallRAM").PivotSelect "", xlDataOnly, True
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=160"
    Selection.FormatConditions(1).Font.Color = -16776961
    Selection.FormatConditions(1).Font.Bold = True
        
     ActiveSheet.PivotTables("UniDis").PivotSelect "", xlDataOnly, True
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=160"
    Selection.FormatConditions(1).Font.Color = -16776961
     Selection.FormatConditions(1).Font.Bold = True
    
     ActiveSheet.PivotTables("DisUni").PivotSelect "", xlDataOnly, True
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=160"
    Selection.FormatConditions(1).Font.Color = -16776961
     Selection.FormatConditions(1).Font.Bold = True
   
    
    Call updatemenudata
    
End Sub

rdetreville · Jun 5, 2015

It looks like my error is partially a bug and is partially due to the pivot tables I added. I'm trying to move updated modules into an earlier, working version of the file to see if this fixes it.

Either way - can someone look at my codes and recommend some ways to make them run faster/clean them up? It would be incredibly helpful and I would appreciate it greatly.

Thanks,

Richard

rdetreville · Jun 5, 2015

Hours later and no luck. I found my error is in the last module and is caused somehow by the pivot table. Also, I had some bad coding in the last module and have corrected here:

Code:

Sub revrec()

Dim wbk1 As Workbook, wbk2 As Workbook

fileStr = Application.GetOpenFilename()

Set wbk1 = ActiveWorkbook
Set wbk2 = Workbooks.Add(fileStr)

wbk2.Sheets("Sheet1").Copy After:=wbk1.Sheets(2)
wbk2.Close

wbk1.Sheets("Sheet1").Name = "RevRec"


wbk1.Sheets(2).Move before:=wbk1.Sheets(1)
wbk1.Sheets(3).Move before:=wbk1.Sheets(2)

Range("A1").EntireRow.Insert
With Range("A1")
.Value = "Highlighted Cells Below Currently have a tracker on SharePoint."
.Font.ColorIndex = 3
.WrapText = True

End With

 Range("B1").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "MENU!A1", TextToDisplay:="Return to Main Report Menu"
              
    With Selection.Font
        .Name = "Verdana"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleSingle
        .ThemeColor = xlThemeColorHyperlink
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    
    
 ActiveSheet.ListObjects("Table_Database6.accdb").Range.AutoFilter Field:=5, _
        Criteria1:="226"
        Calculate
        
        ActiveSheet.ListObjects("Table_Database6.accdb").Range.AutoFilter Field:=7, _
        Criteria1:="Active"
        Calculate
         
         
         ActiveWorkbook.Worksheets(1).Select
         
          Range("J1").EntireColumn.Insert
          Range("J1").EntireColumn.Insert
         
          Range("J1").Value = "District"
       Range("K1").Value = "Unit"
        Rows("1:1").Font.Bold = True
       
       ActiveWorkbook.Worksheets(1).Range("J2").Formula = "=VLOOKUP(I2,Names!$A:$C,2,FALSE)"
       ActiveWorkbook.Worksheets(1).Range("K2").Formula = "=VLOOKUP(I2,Names!$A:$C,3,FALSE)"
       
       ActiveWorkbook.Worksheets(1).Range("J2:K2").Select
    Selection.AutoFill Destination:=Range("J2:K" & Range("L" & Rows.Count).End(xlUp).row)
    Calculate
    ActiveWorkbook.Worksheets(1).Columns("J:K").Copy
     ActiveWorkbook.Worksheets(1).Columns("J:K").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
             
            Range("L1").EntireColumn.Insert
              Range("L1").Value = "Total Hours"
             ActiveWorkbook.Worksheets(1).Range("L2").Formula = "=SUM($M2:$BU2)"
             ActiveWorkbook.Worksheets(1).Range("L2").Select
    Selection.AutoFill Destination:=Range("L2:L" & Range("M" & Rows.Count).End(xlUp).row)
    Calculate
    ActiveWorkbook.Worksheets(1).Columns("L:L").Copy
     ActiveWorkbook.Worksheets(1).Columns("L:L").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
                          
             Dim tbl As ListObject
    Dim rng As Range

Range("A1").CurrentRegion.Select
    Set rng = ActiveSheet.Range(Selection.Address)
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
    tbl.Name = "MainTable"
             
         ThisWorkbook.Sheets("Menu").Copy before:=ActiveWorkbook.Sheets(6)
         ActiveWorkbook.Sheets("Menu").Move before:=ActiveWorkbook.Sheets(1)
Call reportbuild2
End Sub
Sub reportbuild2()
   Dim busy As Range
   
   ActiveWorkbook.Worksheets(2).Select
Range("MainTable[[#Headers],[Team Member]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("MENU").Select
    Range("A2001").Select
    ActiveSheet.Paste
   ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[Total Hours]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("B2001").Select
    ActiveSheet.Paste
   Dim tbl As ListObject
    Dim rng As Range

Range("B2001").CurrentRegion.Select
    Set rng = ActiveSheet.Range(Selection.Address)
   Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
    tbl.Name = "TableBusy"
   
   
    Range("TableBusy[#All]").Select
    ActiveSheet.Range("TableBusy[#All]").RemoveDuplicates Columns:=1, Header:= _
        xlYes
        
         ActiveWorkbook.Worksheets("MENU").ListObjects("TableBusy").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("MENU").ListObjects("TableBusy").Sort.SortFields.Add _
        Key:=Range("TableBusy[[#All],[Total Hours]]"), SortOn:=xlSortOnValues, _
        Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("MENU").ListObjects("TableBusy").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        Call reportbuild3
        End Sub

Sub reportbuild3()
   Dim busy As Range
   
   ActiveWorkbook.Worksheets(2).Select
Range("MainTable[[#Headers],[Team Member]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("MENU").Select
    Range("A3001").Select
    ActiveSheet.Paste
   ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[Total Hours]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("B3001").Select
    ActiveSheet.Paste
   Dim tbl As ListObject
    Dim rng As Range

Range("B3001").CurrentRegion.Select
    Set rng = ActiveSheet.Range(Selection.Address)
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
    tbl.Name = "TableNotBusy"
   
   
    Range("TableBusy[#All]").Select
    ActiveSheet.Range("TableNotBusy[#All]").RemoveDuplicates Columns:=1, Header:= _
        xlYes
        
         ActiveWorkbook.Worksheets("MENU").ListObjects("TableNotBusy").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("MENU").ListObjects("TableNotBusy").Sort.SortFields.Add _
        Key:=Range("TableNotBusy[[#All],[Total Hours]]"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("MENU").ListObjects("TableNotBusy").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        Call reportbuild4
        End Sub
        
        Sub reportbuild4()
   Dim busy As Range
   
   ActiveWorkbook.Worksheets(2).Select
Range("MainTable[[#Headers],[Tracker File Name]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("MENU").Select
    Range("A4001").Select
    ActiveSheet.Paste
   ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[PM]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("B4001").Select
    ActiveSheet.Paste
    ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[Last PM Projections Update]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("C4001").Select
    ActiveSheet.Paste
    ActiveWorkbook.Worksheets(2).Select
    Range("MainTable[[#Headers],[Days since PM update]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("MENU").Select
    Range("D4001").Select
    ActiveSheet.Paste
                  
    
   Dim tbl As ListObject
    Dim rng As Range

Range("A4001").CurrentRegion.Select
    Set rng = ActiveSheet.Range(Selection.Address)
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
    tbl.TableStyle = "TableStyleMedium2"
    tbl.Name = "TablePMUpdate"
   
   
    Range("TablePMUpdate[#All]").Select
    ActiveSheet.Range("TablePMUpdate[#All]").RemoveDuplicates Columns:=1, Header:= _
        xlYes
        
         ActiveWorkbook.Worksheets("MENU").ListObjects("TablePMUpdate").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("MENU").ListObjects("TablePMUpdate").Sort.SortFields.Add _
        Key:=Range("TablePMUpdate[[#All],[Last PM Projections Update]]"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("MENU").ListObjects("TablePMUpdate").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        
        
Columns("A").ColumnWidth = 29
Columns("B:AD").ColumnWidth = 6
       Call finalformatting
        End Sub
Sub finalformatting()
 Sheets("CurrentSharePointTrackerInfo").Select
 Range("A1").EntireRow.Insert
     Range("A1").Select
    ActiveCell.FormulaR1C1 = _
        "Click on a Tracker file name or PM folder name below to open that file or folder."
   
    Range("A1").Select
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Verdana"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    
    Range("D1").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "MENU!A1", TextToDisplay:="Return to Main Report Menu"
              
    With Selection.Font
        .Name = "Verdana"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleSingle
        .ThemeColor = xlThemeColorHyperlink
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    
    Rows("1:1").EntireRow.AutoFit
    ActiveWorkbook.Worksheets(6).Visible = False
    ActiveWorkbook.Worksheets(7).Visible = False
    
  
  Call movecodes
End Sub


Sub updatemenudata()

Dim trackeramount As String
 ActiveWorkbook.Worksheets(1).Select
Range("A4002").Select
    Range(Selection, Selection.End(xlDown)).Select
    trackeramount = Selection.Count
    
 ActiveWorkbook.Worksheets(3).Range("B1000").Formula = "=SUBTOTAL(3,B2:B998)-1"

    
Sheets("MENU").Shapes("datebox").TextFrame.Characters.Text = ActiveWorkbook.Worksheets(2).Range("M1").Value
Sheets("MENU").Shapes("trackcount").TextFrame.Characters.Text = "From Trackers: " & trackeramount


Sheets("MENU").Shapes("revcount").TextFrame.Characters.Text = "From RevRec: " & ActiveWorkbook.Worksheets(3).Range("B1000").Value

 ActiveWorkbook.Worksheets(1).Range("B474").Formula = "=COUNTIF(B101:B473,"">160"")-1"
 
Sheets("MENU").Shapes("busybox").TextFrame.Characters.Text = ActiveWorkbook.Worksheets(1).Range("B474").Value

 
 Call reportready

End Sub


Sub movecodes()
Dim vbComp As Object

str_tmppath = Environ("temp")
Workbooks("SUS-PAR Project Tracker Projections Reporting Tool_development2.xlam").VBProject.VBComponents("CodeMove").Export (tmppath & "CodeMove.bas")
ActiveWorkbook.VBProject.VBComponents.Import (tmppath & "CodeMove.bas")
Call nextreportupdate
End Sub

Sub nextreportupdate()
ActiveWorkbook.Worksheets(1).Select
ActiveSheet.PivotTables("OverallRAM").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
        
        ActiveSheet.PivotTables("UniDis").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
        
        ActiveSheet.PivotTables("DisUni").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
        
          ActiveSheet.PivotTables("PivotDis").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
          
          ActiveSheet.PivotTables("PivotUn").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:="MainTable", _
        Version:=xlPivotTableVersion14)
        
        
        Dim PT As PivotTable, PTField As PivotField
Set PT = ActiveWorkbook.Worksheets(1).PivotTables("PivotDis")
With PT
    .ManualUpdate = True
    For Each PTField In .DataFields
        PTField.Orientation = xlHidden
    Next PTField
    .ManualUpdate = False
End With
Set PT = Nothing

End Sub
Sub nextreportupdate2()

  Dim PT2 As PivotTable, PTField2 As PivotField
Set PT2 = ActiveWorkbook.Worksheets(1).PivotTables("PivotUn")
With PT
    .ManualUpdate = True
    For Each PTField2 In .DataFields
        PTField2.Orientation = xlHidden
    Next PTField2
    .ManualUpdate = False
End With
Set PT = Nothing
        
        
          ActiveWorkbook.Worksheets(1).PivotTables("PivotDis").PivotFields("District").Orientation = _
        xlHidden
    With ActiveWorkbook.Worksheets(1).PivotTables("PivotDis").PivotFields("District")
        .Orientation = xlRowField
        .Position = 1
        End With
        
         ActiveWorkbook.Worksheets(1).PivotTables("PivotUn").PivotFields("Unit").Orientation = _
        xlHidden
    With ActiveWorkbook.Worksheets(1).PivotTables("PivotUn").PivotFields("Unit")
        .Orientation = xlRowField
        .Position = 1
        End With
                        
        Dim currentdate As String
currentdate = ActiveWorkbook.Worksheets(2).Range("M1").Value
 
 ActiveWorkbook.Worksheets(1).PivotTables("PivotDis").AddDataField ActiveSheet.PivotTables( _
        "PivotDis").PivotFields(currentdate), "Total Hours - " & currentdate, xlSum
        
        ActiveWorkbook.Worksheets(1).PivotTables("PivotDis").PivotFields("District").AutoSort _
        xlDescending, "Total Hours - " & currentdate, ActiveSheet.PivotTables("PivotDis"). _
        PivotColumnAxis.PivotLines(1), 1
        
        
        ActiveWorkbook.Worksheets(1).PivotTables("PivotUn").AddDataField ActiveSheet.PivotTables( _
        "PivotUn").PivotFields(currentdate), "Total Hours - " & currentdate, xlSum
        
        ActiveWorkbook.Worksheets(1).PivotTables("PivotUn").PivotFields("Unit").AutoSort _
        xlDescending, "Total Hours - " & currentdate, ActiveSheet.PivotTables("PivotUn"). _
        PivotColumnAxis.PivotLines(1), 1

                                        
               ActiveWorkbook.Worksheets(1).Range("CU1:DA1").Columns.AutoFit
        
        
        Call makered
End Sub
Sub makered()
 ActiveSheet.PivotTables("OverallRAM").PivotSelect "", xlDataOnly, True
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=160"
    Selection.FormatConditions(1).Font.ColorIndex = 3
    Selection.FormatConditions(1).Font.Bold = True
        
     ActiveSheet.PivotTables("UniDis").PivotSelect "", xlDataOnly, True
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=160"
    Selection.FormatConditions(1).Font.ColorIndex = 3
     Selection.FormatConditions(1).Font.Bold = True
    
     ActiveSheet.PivotTables("DisUni").PivotSelect "", xlDataOnly, True
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=160"
    Selection.FormatConditions(1).Font.ColorIndex = 3
     Selection.FormatConditions(1).Font.Bold = True
   
    
    Call updatemenudata
    
End Sub

Sub reportready()
ThisWorkbook.RefreshAll
  Application.GoTo Reference:=Sheets("Menu").Range("a1"), Scroll:=True
End Sub

Norie · Jun 6, 2015

Which line of code causes the error?

By the way, in the first code you posted I noticed you were using Select/Selection etc quite a lot, those are rarely needed and in fact can slow things down.

rdetreville · Jun 6, 2015

Hi there - after detailed searching, it seems the following code is causing the Run-time error above:

Code:

Sub color2()
 
  Application.ScreenUpdating = False
 Dim rng9 As Range
Dim row9 As Range
Dim cell9 As Range

Set rng9 = Sheets("Report - RAM").Range("A1:IUA1")

For Each row9 In rng9.Rows
  For Each cell9 In row9.Cells
    If cell9.Value >= 40909 And cell9.Value <= 43465 Then cell9.Font.ColorIndex = 5
    
  Next cell9
  
Next row9
 Application.ScreenUpdating = True
 Stop

Call color3
 End Sub

When I step through this code, it works fine, but is very very slow. Maybe the macro is trying to move forward before this has completed? I'm just trying to turn all cells in row 1 that are between the values of 40909 and 43465 blue. Is there a faster way to do this perhaps?

And yes, I am certain my heavy use of "Select/Selection" is causing a bit of a slow down. I'm afraid I'm not quite sure how to speak VBA well enough to not use the select method. I will do some research though.

rdetreville · Jun 6, 2015

I found the straw that broke the camel's back - I had added some pasted linked pictures of pivot tables on a template sheet that gets copied at the very end. I guess the system didn't like that, and it slowed down the processing for the whole series of macros. I deleted those pictures and now everything is running quickly again. Best seven hours of searching I've ever had

Macros lagging and now crashing after working perfectly - can't find problem.

rdetreville

New Member

Excel Facts

rdetreville

New Member

rdetreville

New Member

rdetreville

New Member

Norie

Well-known Member

rdetreville

New Member

rdetreville

New Member

Similar threads

Forum statistics

Share this page

Macros lagging and now crashing after working perfectly - can't find problem.

rdetreville

New Member

Excel Facts

rdetreville

New Member

rdetreville

New Member

rdetreville

New Member

Norie

Well-known Member

rdetreville

New Member

rdetreville

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock