I have a large Microsoft Excel file that is shared between users in my office. The file has a macro and a data set. The file is used in the last two weeks of every third month. The file worked fine until Christmas, but in March we ran into errors. The following error occurred while opening the file.
After clicking Yes, the following appeared.
Macro Code:
Sub Update()
'Declaring Variables.
Dim Number_Rows As Long
Dim Oppt As String
Dim Array_Oppt() As String
Dim Rows_Array As Integer
'Stops screen refreshing to save time.
Application.ScreenUpdating = False
'removing any data validation and conditional formatting
Sheet1.Activate
Cells.Select
Selection.Validation.Delete
Selection.FormatConditions.Delete
'Assigning value to array.
Rows_Array = 0
ReDim Preserve Array_Oppt(Rows_Array)
'Moving "Other" rows to the end of the data
Sheet1.Select
Selection.AutoFilter Field:=23, Criteria1:= _
"OTHER"
Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Select
Selection.EntireRow.Select
Range(Selection, Selection.End(xlDown)).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheet8.Select
Sheet8.Range("A1").Select
ActiveSheet.Paste
Sheet1.Select
Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Select
Selection.EntireRow.Select
Range(Selection, Selection.End(xlDown)).SpecialCells(xlCellTypeVisible).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter
Number_Rows = Application.WorksheetFunction.CountA(Range("A:A"))
Sheet8.Select
Selection.Cut
Sheet1.Activate
Range("A" & Number_Rows + 1).Select
ActiveSheet.Paste
'Counting number of rows.
Number_Rows = Application.WorksheetFunction.CountA(Range("A:A"))
'Loop to check if oppt if unit or non unit deal. Checks if oppt is in array and adds oppt if not.
'Calculates total revenue per opp.
For i = 2 To Number_Rows
Oppt = Range("I" & i)
'In array already.
If UBound(Filter(Array_Oppt, Oppt)) >= 0 Then
'Non Unit deal in the array already. Deletes line and shifts row up as well as i up.
If Range("W" & i) = "OTHER" Then
Rows(i).Select
Selection.Delete Shift:=xlUp
Number_Rows = Number_Rows - 1
i = i - 1
'Unit deal in the array already.
Else
Range("J" & i) = ""
End If
'Not in array so needs to be added.
Else
Range("J" & i) = Application.WorksheetFunction.SumIf(Range("I:I"), Oppt, Range("J:J"))
If Range("W" & i) = "OTHER" Then
Range(Cells(i, 19), Cells(i, 26)) = ""
Else
End If
'Redefines the size of the array factoring in new added row.
ReDim Preserve Array_Oppt(Rows_Array)
Array_Oppt(Rows_Array) = Oppt
Rows_Array = Rows_Array + 1
End If
Next
'Adds blank column for business manager.
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1") = "Business Manager"
'Updates the titles of the last columns in file
Range("AB1") = Date - 2
Range("AC1") = Date - 1
Range("AD1") = "Today"
Range("AE1") = "Focus List"
Range("AF1") = "% Chance"
Range("AG1") = "Allocation Status"
Range("AH1") = "New PO Date"
Range("AI1") = Date - 3
Range("AJ1") = Date - 4
Range("AK1") = Date - 5
Range("AL1") = Date - 6
Range("AM1") = Date - 7
Range("AN1") = Date - 8
Range("AO1") = Date - 9
Range("AP1") = Date - 10
Range("AQ1") = "Partner Grouping"
Range("AR1") = "VNX Models"
Range("AS1") = "Commit + X"
Range("AT1") = "Country"
Range("AU1") = "Theater"
'Moves to Sheet2 and copies Upside X column B to the end (column AV) for the purpose of VLookup. Then returns to Sheet1.
Sheet2.Activate
Sheet2.Columns("B:B").Select
Application.CutCopyMode = False
Selection.Copy
Sheet2.Columns("AV:AV").Select
ActiveSheet.Paste
Sheet1.Activate
'Loop to add Linked status; and to complete VLookups from yesterday.
For i = 2 To Number_Rows
'If to check linked status
If Range("L" & i) = "" Then
Range("M" & i) = "Not Linked"
Else
Range("M" & i) = "Linked"
End If
'Vlookups
On Error Resume Next
Err.Clear
'Vlookup to add business manager
Sheet1.Range("H" & i) = Application.VLookup(Sheet1.Range("G" & i), Sheet3.Range("A:B"), 2, False)
'Vlookup to add comments from 2 days ago to column AB
Sheet1.Range("AB" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 20, False)
'Vlookup to add comments from yesterday to column AC
Sheet1.Range("AC" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 21, False)
'Vlookup to add data from Focus List column
Sheet1.Range("AE" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 22, False)
'Vlookup to add data from % Chance column
Sheet1.Range("AF" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 23, False)
'Vlookup to add data from Allocation Status column
Sheet1.Range("AG" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 24, False)
'Vlookup to add data from New PO Date column
Sheet1.Range("AH" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 25, False)
'Vlookup to add data from 3 days ago to column AI
Sheet1.Range("AI" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 19, False)
'Vlookup to add data from 4 days ago to column AJ
Sheet1.Range("AJ" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 26, False)
'Vlookup to add data from 5 days ago to column AK
Sheet1.Range("AK" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 27, False)
'Vlookup to add data from 6 days ago to column AL
Sheet1.Range("AL" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 28, False)
'Vlookup to add data from 7 days ago to column AM
Sheet1.Range("AM" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 29, False)
'Vlookup to add data from 8 days ago to column AN
Sheet1.Range("AN" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 30, False)
'Vlookup to add data from 9 days ago to column AO
Sheet1.Range("AO" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 31, False)
'Vlookup to add data from 10 days ago to column AP
Sheet1.Range("AP" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AR"), 32, False)
'Vlookup to add data to VNX Models column AR from VNX Models sheet 5 using Item Number column
Sheet1.Range("AR" & i) = Application.VLookup(Sheet1.Range("W" & i), Sheet5.Range("A:B"), 2, False)
'Vlookup to add data to Upside X column B
Sheet1.Range("B" & i) = Application.VLookup(Sheet1.Range("J" & i), Sheet2.Range("J:AV"), 39, False)
'Vlookup to add Country to Country column AT based on Mapping Table sheet 4
Sheet1.Range("AT" & i) = Application.VLookup(Sheet1.Range("G" & i), Sheet4.Range("A:B"), 2, False)
'Vlookup to add Theater to Theater column AU based on Mapping Table sheet 4
Sheet1.Range("AU" & i) = Application.VLookup(Sheet1.Range("G" & i), Sheet4.Range("A:C"), 3, False)
If Err.Number = 0 Then
Else
End If
Next
'Adding Formula for Commit + X Column AS for Conf Call Analysis file
Range("AS2").Formula = "=IF(C2=""Commit"",""Commit+X"",IF(B2=""X"",""Commit+X"",""""))"
Range("AS2").Select
Selection.AutoFill Destination:=Range("AS2:AS" & Number_Rows)
'***********FORMATTING BELOW**************
'Format Revenue column K - no decimal, 1,000 seperator.
Columns("K:K").Select
Selection.NumberFormat = "#,##0"
'Format Forecast Close Date column P
Columns("P:P").Select
Selection.NumberFormat = "d/m/yyyy"
'Format Focus List column AE
Columns("AE:AE").Select
Selection.NumberFormat = "d/m/yyyy"
'Format % Chance column AF
Columns("AF:AF").Select
Selection.NumberFormat = "0%"
'Format cells with Dates as titles to dd-mm rather than long date
Range("AB1:AC1").Select
Selection.NumberFormat = "d-mmm"
Range("AI1:AP1").Select
Selection.NumberFormat = "d-mmm"
'Add Data Validation to Allocation Status column
Columns("AG:AG").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=_Allocation"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'Sorting by Description A-Z, Business Manager A-Z and Revenue $ Largest to Smallest
Sheet1.Sort.SortFields.Clear
Sheet1.Sort.SortFields.Add Key:=Range("C2:C" & Number_Rows _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Sheet1.Sort.SortFields.Add Key:=Range("H2:H" & Number_Rows _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Sheet1.Sort.SortFields.Add Key:=Range("K2:K" & Number_Rows _
), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With Sheet1.Sort
.SetRange Range("A1:AU" & Number_Rows)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Hide Columns Quarter AA,Primary Partner OO, Reporting Product Type TT, Product Line VV, Opportunity Source Code QQ
Columns("A:A").Select
Selection.EntireColumn.Hidden = True
Columns("O:O").Select
Selection.EntireColumn.Hidden = True
Columns("T:T").Select
Selection.EntireColumn.Hidden = True
Columns("Q:Q").Select
Selection.EntireColumn.Hidden = True
Columns("V:V").Select
Selection.EntireColumn.Hidden = True
'Colours Today column AD yellow
Columns("AD:AD").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Colours Allocation Status column AG blue
Columns("AG:AG").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Bold Headings in row 1
Rows("1:1").Select
Selection.Font.Bold = True
'Adding Conditional Formatting Order Number column J, to highlight all duplicate values so that all oppts that have more than one row are red.
Columns("J:J").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'Adding last updated date
Sheet3.Range("J1") = Date
'Allows screen to refresh at the end
Application.ScreenUpdating = True
'Msgbox to advise when macro is complete.
MsgBox ("File is now updated.")
End Sub
I figured out a number of works, but this slows down our productivity, and the error may resume later that day. Can someone tell me what is the likely cause of this problem?