EDIT: the trigger seems to be when LastRowNo is 3, which is the same value as Const StartRowNo, which makes the macro copy a cell into itself. I inserted If LastRowNo = StartRowNo Then Exit Sub right before the copy function and it did the trick, but I feel this is just a workaround because there should be no problem in a macro that copies a cell into itself, even if it serves no purpose. I'll leave the question open for possible insights on the original problem.
I have the code shown below that was working perfectly at first, but on some occasions, it starts to copy content from cell A3 across the entire sheet, from columns 1 to 25 and to whatever is the last row the code gets on LastRowNo variable.
The line responsible for this is:
.Range(StartRow).Copy _
Destination:=.Range(StartRow & ":A" & LastRowNo).SpecialCells(xlCellTypeBlanks)
If I suppress this line, then it starts to copy checkboxes across the same range as above since there is another copy function right below.
For ColumnNo = 16 To 25
Escopo.Cells(StartRowNo, ColumnNo).Copy _
Destination:=.Range(Escopo.Cells(StartRowNo, ColumnNo), Escopo.Cells(LastRowNo, ColumnNo)).SpecialCells(xlCellTypeBlanks)
Next
What's more, say at the time of the error the LastRowNo variable value was 20 for argument's sake. After deleting all data and setting LastRowNo variable to 4 which in theory would copy the data even with errors up to row 4, this behaviour keeps happening up to row 20 regardless of LastRowNo value. This only changes when LastRowNo is set to a value bigger than 20.
It is as if the macro stores this value and keeps it even after End Sub and only overrides for a bigger value.
I am unable to reproduce this error consistently since it comes and goes seemingly without a trigger.
Code:
Sub FormatWB()
Dim StartRow As String
Dim LastRowNo As Long
Dim ColumnNo As Long
Dim Escopo As Worksheet
Dim Material As Worksheet
Dim PrecoMTL As Worksheet
Dim PrecoRev As Worksheet
Dim Orcamento As Worksheet
Const StartRowNo = 3
Set Escopo = ActiveWorkbook.Worksheets("Escopo")
Set Material = ActiveWorkbook.Worksheets("Material")
Set PrecoMTL = ActiveWorkbook.Worksheets("Preço Material")
Set PrecoRev = ActiveWorkbook.Worksheets("Preço Revestimento")
Set Orcamento = ActiveWorkbook.Worksheets("Orçamento Final")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Escopo 'Calc to limit range based on number of cells not empty
LastRowNo = .Cells(.Rows.Count, "B").End(xlUp).Row 'This gets updated inside RemoveSumDuplicates Sub
If LastRowNo < StartRowNo Then Exit Sub
StartRow = "A" & StartRowNo
Call RemoveSumDuplicates(StartRowNo, LastRowNo, StartRow)
End With
With ActiveWorkbook 'Format all Sheets equaly up to last colunm, referenced in " "
FormatSheet Escopo.Range(StartRow & ":Y" & LastRowNo)
FormatSheet Material.Range(StartRow & ":N" & LastRowNo)
FormatSheet PrecoMTL.Range(StartRow & ":P" & LastRowNo)
FormatSheet PrecoRev.Range(StartRow & ":O" & LastRowNo)
FormatSheet Orcamento.Range(StartRow & ":Q" & LastRowNo)
End With
With Escopo
On Error Resume Next
.Range("A3").Formula = "=IF(ISBLANK(B3),"""",IFERROR(A2+1,1))"
.Range(StartRow & ":A" & LastRowNo).Font.Bold = True
.Range("P3:R3").CellControl.SetCheckbox
.Range("S3").FormulaArray = "=INDEX('Database QPs e IPs'!$H$2:$H$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
.Range("T3").FormulaArray = "=INDEX('Database QPs e IPs'!$G$2:$G$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
.Range("U3").FormulaArray = "=INDEX('Database QPs e IPs'!$I$2:$I$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
.Range("V3").FormulaArray = "=INDEX('Database QPs e IPs'!$N$2:$N$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
.Range("W3").FormulaArray = "=INDEX('Database QPs e IPs'!$K$2:$K$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
.Range("X3").FormulaArray = "=INDEX('Database QPs e IPs'!$J$2:$J$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
.Range("Y3").FormulaArray = "=INDEX('Database QPs e IPs'!$O$2:$O$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
.Range(StartRow).Copy _
Destination:=.Range(StartRow & ":A" & LastRowNo).SpecialCells(xlCellTypeBlanks)
For ColumnNo = 16 To 25
Escopo.Cells(StartRowNo, ColumnNo).Copy _
Destination:=.Range(Escopo.Cells(StartRowNo, ColumnNo), Escopo.Cells(LastRowNo, ColumnNo)).SpecialCells(xlCellTypeBlanks)
Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub FormatSheet(rng As Range)
With rng
.UnMerge
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.NumberFormat = "General"
.Font.Bold = False
.Font.Italic = False
.Font.Underline = False
.Font.Name = "Calibri"
.Font.Size = 11
.Interior.ColorIndex = 0
.Font.Color = vbBlack
End With
End Sub
Sub RemoveSumDuplicates(StartRowNo As Long, LastRowNo As Long, StartRow As String)
Dim Value As Object
Dim RowNo As Long
Dim Label As String
Set Value = CreateObject("Scripting.Dictionary")
For RowNo = StartRowNo To LastRowNo
Label = Cells(RowNo, 2)
Value(Label) = Cells(RowNo, 7) + Value(Label)
Next RowNo
Range(StartRow & ":Y" & LastRowNo).RemoveDuplicates Columns:=Array(2, 2)
LastRowNo = Cells(Rows.Count, "B").End(xlUp).Row
For RowNo = StartRowNo To LastRowNo
Label = Cells(RowNo, 2)
If Not Cells(RowNo, 7) = Value(Label) Then Cells(RowNo, 7) = Value(Label)
Next RowNo
End Sub