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 below that at first was working perfectly, but on some ocasions 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 supress 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.

THE 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

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 below that at first was working perfectly, but on some ocasions 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 supress 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.

THE 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

• excel
• vba

Share Improve this question Follow edited Mar 4 at 12:11 Bkviegas asked Mar 4 at 11:00 BkviegasBkviegas 3177 bronze badges 5

• At first glance, if the code is in the workbook containing these sheets, use ThisWorkbook instead of ActiveWorkbook ensuring the correct workbook. In the RemoveSumDuplicates procedure, add a worksheet object parameter to the signature: Sub RemoveDuplicates(ByVal ws As Worksheet, ...) and prepend Cells and Range with it (ws.Cells, ws.Range...) ensuring the correct worksheet. Then call it with RemoveSumDuplicates Escopo, StartRowNo, LastRowNo, StartRow. – VBasic2008 Commented Mar 4 at 11:35
• @VBasic2008 Thanks for the Input. I did the changes you suggested, but the error persists. I ran the code again but without calling 'RemoveSumDuplicates' Sub and the error is still triggering. – Bkviegas Commented Mar 4 at 11:40
• 1 Add On Error Goto 0 after .Range("Y3").FormulaArray... – CDP1802 Commented Mar 4 at 13:09
• @CDP1802 I did something similar, If LastRowNo = StartRowNo Then Exit Sub and it did the trick. I just don't understand why copying a cell into itself should be a problem, but problem solved nevertheless. – Bkviegas Commented Mar 4 at 13:25
• 1 See stackoverflow/questions/49924308/…. You can replicate with Sub test() : Range("A3") = "A3" : Range("E10") = "E10" : Range("A3").Copy Destination:=Range("A3").SpecialCells(xlCellTypeBlanks) : End Sub in a blank sheet. – CDP1802 Commented Mar 4 at 13:52

Add a comment  | 

1 Answer 1

Sorted by: Reset to default 0

Sumup Unique Items

• It is assumed that the range contains only values, no formulas, i.e., the result will be only values.

• Not tested, it compiles.

• Call it with

  RemoveSumDuplicates Escopo, StartRowNo, LastRowNo
  

  Note that I excluded the StartRow parameter.

Sub RemoveSumDuplicates( _
        ByVal ws As Worksheet, _
        ByVal StartRowNo As Long, _
        ByVal LastRowNo As Long)
    
    ' Define constants.
    Const DATA_COLUMNS As String = "A:Y"
    Const LABELS_COLUMN As Long = 2
    Const SUM_COLUMN As Long = 7
    
    ' Reference the range and return its values in an array.
    Dim RowDiff As Long: RowDiff = StartRowNo - 1
    Dim sRowsCount As Long: sRowsCount = LastRowNo - RowDiff
    If sRowsCount < 1 Then Exit Sub ' no data
    Dim rg As Range: Set rg = ws.Columns(DATA_COLUMNS) _
        .Resize(sRowsCount).Offset(RowDiff)
    Dim ColsCount As Long: ColsCount = rg.Columns.Count
    Dim Data() As Variant: Data = rg.Value
    
    ' Populate the dictionary's keys with the labels,
    ' and the items (values) with collections holding the matching row numbers.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive: 'A=a'
    Dim Value As Variant, sRow As Long, Label As String
    For sRow = 1 To sRowsCount
        Label = Data(sRow, LABELS_COLUMN)
        Value = Data(sRow, SUM_COLUMN)
        If VarType(Value) = vbDouble Then ' is a number
            If Not dict.Exists(Label) Then Set dict(Label) = New Collection
            dict(Label).Add sRow
        End If
    Next sRow
    
    ' Populate the top of the array with unique labelled summed up matches.
    Dim Key As Variant, Item As Variant, dRowsCount As Long, Col As Long
    Dim Summed As Double, IsFirst As Boolean
    For Each Key In dict.Keys
        IsFirst = True
        For Each Item In dict(Key)
            sRow = Item
            If IsFirst Then ' write row values
                dRowsCount = dRowsCount + 1
                For Col = 1 To ColsCount
                    Data(dRowsCount, Col) = Data(sRow, Col)
                Next Col
                Summed = Data(sRow, SUM_COLUMN)
                IsFirst = False
            Else ' sum up
                Summed = Summed + Data(sRow, SUM_COLUMN)
            End If
        Next Item
        Data(dRowsCount, SUM_COLUMN) = Summed ' write sum
    Next Key
    
    ' Write the modified values back to the range and clear below.
    rg.Resize(dRowsCount).Value = Data
    rg.Resize(sRowsCount - dRowsCount).Offset(dRowsCount).Clear

End Sub