Having some random trouble with my code in terms of performance and sometimes it random fails as I fear I'm not structuring it correctly. Anyone have any suggestions for anything to do better?
For instance instead of Application. is it better to do With .Application? Also, for similar lines such as wbTarget.Worksheets, can I do something similar?
Anything else I could do better or something you'd recommend to do different?
Thank you!
Sub ClientPrep()
Dim wbTarget As Workbook
Dim strPathBin As String
Dim strSSPath As String
Dim strTab As String
Dim strInt As Integer
'Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = False
Application.CalculateBeforeSave = False
Application.Calculation = -4135
'''
Sheets("Results").Activate
WeekEndDate = Format(Application.WorksheetFunction.Max(Columns("F")), "mm-dd-yyyy")
Sheets("Cover Page").Activate
strPathBin = ""
strSSPath = "C:\Users\administrator\GCP\GCP-AMS - Reporting\Weekly_Hours_Reports" & "\_Client_Copy\" & WeekEndDate & "\"
'::-- Set batch variables --::'
Shell ("cmd.exe /C SETx ClientCopyBin " & "_Client_Copy\" & WeekEndDate & "\")
Shell ("cmd.exe /C SETx WeekEndDate " & WeekEndDate)
'::-- Create Archive Directory --::'
If Dir(strSSPath, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & strSSPath & """")
End If
'::-- Get Client Name --::'
strString = Replace(ActiveWorkbook.Worksheets("Cover Page").Range("C2"), " ", "_")
strName = WeekEndDate & "_" & strString & "_Hours_Report.xlsm"
'::-- Remove Worbook if Exist --::'
If Dir(strSSPath & strName) <> "" Then
Kill strSSPath & strName
End If
Application.Wait (Now + TimeValue("0:00:02"))
'::-- Make Workbook Copy --::'
ActiveWorkbook.SaveCopyAs strSSPath & strName
'::-- Open Client Workbook --::'
Application.DisplayAlerts = False
Set wbTarget = Workbooks.Open(strSSPath & strName)
'Application.DisplayAlerts = True
'::-- Hide Period Tabs if no data exists --::'
Dim i As Integer
For i = 1 To 12
strTab = "P" & i
Sheets(strTab).Cells.Copy
Sheets(strTab).Cells.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
If i > m Then wbTarget.Worksheets(strTab).Visible = xlSheetHidden
wbTarget.Worksheets(strTab).Range("B:B").EntireColumn.AutoFit
Sheets(strTab).Activate
ActiveSheet.Cells(1, 1).Select
Next
For i = 1 To 4
strTab = "Q" & i
Sheets(strTab).Cells.Copy
Sheets(strTab).Cells.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
If i > q Then wbTarget.Worksheets(strTab).Visible = xlSheetHidden
wbTarget.Worksheets(strTab).Range("B:B").EntireColumn.AutoFit
Sheets(strTab).Activate
ActiveSheet.Cells(1, 1).Select
Next i
Sheets("Overage_Tracker").Cells.Copy
Sheets("Overage_Tracker").Cells.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveSheet.Cells(1, 1).Select
'''Exception
If strString = "Victra" Then
With Sheets("Results")
LastP = .Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For r = LastP To 2 Step -1
If .Cells(r, "B") <> "Victra - Managed Services" Then .Cells(r, "B").EntireRow.Delete
Next r
End With
Else
'::-- Clear Results Tab --::'
wbTarget.Worksheets("Results").Cells.Clear
End If
'::-- Hide Sheets --::'
On Error Resume Next
wbTarget.Worksheets("Contract").Visible = xlSheetHidden
wbTarget.Worksheets("Results").Visible = xlSheetHidden
wbTarget.Worksheets("Overage_Tracker").Visible = xlSheetHidden
wbTarget.Worksheets("Instructions").Visible = xlSheetHidden
wbTarget.Worksheets("Task").Visible = xlSheetHidden
wbTarget.Worksheets("Rate_Card").Visible = xlSheetHidden
wbTarget.Worksheets("Non-Standard_Tracker").Visible = xlSheetHidden
On Error GoTo 0
wbTarget.Worksheets("Cover Page").Activate
wbTarget.SaveAs strSSPath & strName, AccessMode:=xlExclusive, ConflictResolution:=xlLocalSessionChanges
'wbTarget.Save
wbTarget.Close
Set wbTarget = Nothing
ActiveWorkbook.Worksheets("Cover Page").Activate
End Sub
Replace the copy/paste with a direct value assignment only of the used range. Optimise the row deletes using Union.
Option Explicit
Sub ClientPrepSO()
Const FOLDER = "C:\Users\administrator\GCP\GCP-AMS - Reporting\Weekly_Hours_Reports"
Dim wbTarget As Workbook
Dim wsResults As Worksheet, wsCover As Worksheet, ws As Worksheet
Dim n As Long, mth As Long, qu As Long, r As Long
Dim rngDelete As Range, sClient As String, lastRow As Double
Dim sReport As String, sArchivePath As String, sCopy As String
Dim t0 As Single: t0 = Timer
Dim dtWeekEnd As Date, sWeekEnd As String
With ThisWorkbook
Set wsResults = .Sheets("Results")
Set wsCover = .Sheets("Cover Page")
End With
' week ending
With wsResults
dtWeekEnd = Application.WorksheetFunction.Max(.Columns("F"))
sWeekEnd = Format(dtWeekEnd, "mm-dd-yyyy")
mth = Month(dtWeekEnd)
qu = 1 + Int((mth - 1) / 3)
End With
' Set batch variables
'Shell ("cmd.exe /C SETx ClientCopyBin " & "_Client_Copy\" & sWeekEnd & "\")
'Shell ("cmd.exe /C SETx WeekEndDate " & sWeekEnd)
' client name / report
With wsCover
sClient = Replace(.Range("C2"), " ", "_")
sReport = sWeekEnd & "_" & sClient & "_Hours_Report.xlsm"
End With
' create archive directory
sArchivePath = FOLDER & "\_Client_Copy\" & sWeekEnd & "\"
sCopy = sArchivePath & sReport
If Dir(sArchivePath, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & sArchivePath & """")
Application.Wait (Now + TimeValue("0:00:02"))
' Remove Workbook if exists
ElseIf Dir(sCopy) <> "" Then
Kill sCopy
End If
' Make Workbook Copy
ActiveWorkbook.SaveCopyAs sCopy
Set wbTarget = Workbooks.Open(sCopy)
Application.ScreenUpdating = False
With wbTarget
For n = 1 To 12
With .Sheets("P" & n)
.UsedRange = .UsedRange.Value
.Range("B:B").EntireColumn.AutoFit
If n > mth Then .Visible = xlSheetHidden
End With
Next
For n = 1 To 4
With .Sheets("Q" & n)
.UsedRange = .UsedRange.Value
.Range("B:B").EntireColumn.AutoFit
If n > qu Then .Visible = xlSheetHidden
End With
Next
With .Sheets("Overage_Tracker")
.UsedRange = .UsedRange.Value
End With
'''Exception
If sClient = "Victra" Then
With .Sheets("Results")
lastRow = .Range("B" & Rows.Count).End(xlUp).Row
For r = 2 To lastRow
If .Cells(r, "B") <> "Victra - Managed Services" Then
If rngDelete Is Nothing Then
Set rngDelete = .Cells(r, 1)
Else
Set rngDelete = Application.Union(rngDelete, .Cells(r, 1))
End If
End If
Next
If Not rngDelete Is Nothing Then
'rngDelete.Interior.Color = vbRed 'use this not delete to test
rngDelete.EntireRow.Delete
End If
End With
Else
' Clear Results Tab
.Worksheets("Results").Cells.Clear
End If
' hide sheets
For Each ws In .Sheets
ws.Activate
ws.Cells(1, 1).Select
Select Case ws.Name
Case "Contract", "Results", "Overage_Tracker", "Instructions", _
"Task", "Rate_Card", "Non-Standard_Tracker"
ws.Visible = xlSheetHidden
End Select
Next
.Sheets("Cover Page").Activate
Application.DisplayAlerts = False
.SaveAs sCopy, AccessMode:=xlExclusive, ConflictResolution:=xlLocalSessionChanges
Application.DisplayAlerts = True
.Close
End With
Application.ScreenUpdating = True
wsCover.Activate
MsgBox "Completed in " & Format(Timer - t0, "0.0s"), vbInformation
End Sub