Counting and Deleting Duplicate Data

Question

Can anyone help me optimize the current VBA code below? It is taking 20 seconds currently to collect,store, check and validate 1000 data's.

This program takes specific values from multiple sheets and does addition as the values goes beyond one column or row so loop for addition. And uses 4 values to check for duplicate data and then if found it add's the total and prints in one row and deletes the duplicate. And finally Checking the value and alignment as well.

Option Explicit
Public s, c, r2, r, i, j, k, i3, i1, i2, r1, j1, j2, i4, r3, sum As Long
Public wh As String
Public ws, wd As Worksheet
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
Sub MainStart()
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
Dim wsTest As Worksheet
Const strSheetName As String = "Report"

Set wsTest = Nothing
On Error Resume Next
    Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
    Worksheets.Add.Name = strSheetName
End If
Application.ScreenUpdating = False
i1 = 1
j1 = 2
j2 = 2
i2 = 2
For Each ws In ThisWorkbook.Worksheets                                                          
   If ws.Name <> "Report" And ws.Name <> "Pending Tasks" Then
       With ws
            wh = ws.Name
            r = Worksheets(wh).Range("c5").SpecialCells(xlCellTypeLastCell).Row                                            ' getting No of row in a sheet
            r = r - 1                                                                                   ' To remove the total row which may not be required
            c = Worksheets(wh).Range("A13").SpecialCells(xlCellTypeLastCell).Column                                  ' To get the no coloumn
            c = c - 1
            Cells(1, 1).Value = "Release"
            Cells(1, 2).Value = "Project ID"
            Cells(1, 3).Value = "Sub Category"
            Cells(1, 4).Value = "ROM"
            Cells(1, 5).Value = "Hours Spent"
            Cells(1, 6).Value = "Status"
            Cells(1, 8).Value = "Month"
            Cells(1, 7).Value = "Area"
            Cells(1, 14).Value = "Location"
            Cells(1, 15).Value = "Resorce Name"
            Cells(1, 16).Value = "Max Allowed Hours"
            Cells(1, 17).Value = "Hours Allocated"
            Cells(1, 18).Value = "Status"
            Cells(1, 18).Value = "Month"
            Cells(1, 19).Value = "Comment"
            For i = 5 To r
                Worksheets(wh).Cells(i, 1).Copy Destination:=Sheets("Report").Range("A" & j1)
                Worksheets(wh).Cells(i, 2).Copy Destination:=Sheets("Report").Range("b" & j1)
                Worksheets(wh).Cells(i, 6).Copy Destination:=Sheets("Report").Range("c" & j1)
                Worksheets(wh).Cells(i, 10).Copy Destination:=Sheets("Report").Range("d" & j1)
                Worksheets(wh).Cells(i, 4).Copy Destination:=Sheets("Report").Range("g" & j1)
                Call cal
                j1 = j1 + 1
            Next i
            For j = 13 To c
                Worksheets(wh).Cells(1, j).Copy Destination:=Sheets("Report").Range("N" & j2)
                Worksheets(wh).Cells(2, j).Copy Destination:=Sheets("Report").Range("O" & j2)
                Worksheets(wh).Cells(3, j).Copy Destination:=Sheets("Report").Range("P" & j2)
               ' j = 0
                Call cal1
                j2 = j2 + 1
            Next j
         End With
    End If
Next
Call redu
Call aling
Call calcheck
Call Onoffuti
Worksheets("Report").Rows().AutoFit
Call msg
Application.ScreenUpdating = True
End Sub
Sub cal()
   For k = 13 To c
       sum = sum + Worksheets(wh).Cells(i, k)
    Next k
    i1 = i1 + 1
    Worksheets("Report").Range("e" & i1).Value = sum
    sum = 0
    Worksheets("Report").Range("h" & i1).Value = wh
   End Sub
   Sub cal1()
   For s = 5 To r
       sum = sum + Worksheets(wh).Cells(s, j)
    Next s
    Worksheets("Report").Range("q" & i2).Value = sum
     sum = 0
    Worksheets("Report").Range("r" & i2).Value = wh
    i2 = i2 + 1
    End Sub
    Sub calcheck()
Sheets("Report").Select
 r2 = Range("n1").SpecialCells(xlCellTypeLastCell).Row
 r1 = Range("n1").SpecialCells(xlCellTypeLastCell).Row
        For i2 = 2 To r1
            If Range("d" & i2).Value > Range("e" & i2).Value Then
                Range("f" & i2) = "Resource Not fully Utilised"
                Range("a" & i2, "g" & i2).Interior.Color = RGB(0, 255, 0)
            ElseIf Range("d" & i2).Value < Range("e" & i2).Value Then
                Range("f" & i2) = "Resource over Utilised"
                Range("a" & i2, "g" & i2).Interior.Color = RGB(255, 0, 0)
            ElseIf (Range("d" & i2).Value <> 0) = True And (Range("e" & i2).Value = 0) = True Then
                Range("f" & i2) = "Resource not Allocatted"
            End If
        Next i2
        For i3 = 2 To r2
            If Range("p" & i3).Value > Range("q" & i3).Value Then
                Range("s" & i3) = "Resource Not fully Utilised"
                Range("n" & i3, "s" & i3).Interior.Color = RGB(0, 255, 0)
            ElseIf Range("p" & i3).Value < Range("q" & i3).Value Then
                Range("s" & i3) = "Resource over Utilised"
                Range("n" & i3, "s" & i3).Interior.Color = RGB(255, 0, 0)
            ElseIf (Range("p" & i3).Value <> 0) = True And (Range("q" & i3).Value = 0) = True Then
                Range("s" & i3) = "Resource not Allocatted"
            End If
        Next i3
  End Sub
  Sub aling()
  Sheets("Report").Select
  r1 = Worksheets("Report").UsedRange.Rows.Count
Worksheets("Report").Range("A1:g" & r1).ClearFormats
Worksheets("Report").Range("N1:Q" & r1).ClearFormats
Worksheets("Report").ListObjects.Add(xlSrcRange, Range("A1:h" & r1), , xlYes).Name = "myTable1"
Worksheets("Report").ListObjects.Add(xlSrcRange, Range("N1:s" & r1), , xlYes).Name = "myTable2"
 End Sub
 Sub redu()
Dim intRow1 As Integer
Dim intRow2 As Integer
Dim strNameSurname1 As String
Dim strNameSurname2 As String
Dim strNameSurname3 As String
Dim strNameSurname4 As String
intRow1 = 2
intRow2 = intRow1 + 1
With Worksheets("Report")
    Do While .Cells(intRow1, 1).Value <> Empty
        Do While .Cells(intRow2, 1).Value <> Empty
            strNameSurname1 = CStr(.Cells(intRow1, 1).Value) & CStr(.Cells(intRow1, 2).Value) & CStr(.Cells(intRow1, 3).Value) & CStr(.Cells(intRow1, 8).Value)
            strNameSurname2 = CStr(.Cells(intRow2, 1).Value) & CStr(.Cells(intRow2, 2).Value) & CStr(.Cells(intRow1, 3).Value) & CStr(.Cells(intRow1, 8).Value)
            If strNameSurname1 = strNameSurname2 Then
                .Cells(intRow1, 5).Value = .Cells(intRow1, 5).Value + .Cells(intRow2, 5).Value
                .Range("A" & intRow2, "h" & intRow2).Delete
                intRow2 = intRow2 - 1
            End If
            intRow2 = intRow2 + 1
        Loop
        intRow1 = intRow1 + 1
        intRow2 = intRow1 + 1
    Loop
End With
End Sub
Sub Onoffuti()
Dim p, d, q, f As Variant
Sheets("Report").Select
i3 = 1
i4 = 1
r2 = 0
r3 = 0
r2 = Range("a1").SpecialCells(xlCellTypeLastCell).Row
r3 = Range("a1").SpecialCells(xlCellTypeLastCell).Row
For i3 = 2 To r2
    p = Range("n" & i3).Value
    d = Range("r" & i3).Value
    If p = "on" Or p = "ON" Or p = "On" And (Range("p" & i3).Value < Range("q" & i3).Value) = True Then
       For i4 = 2 To r3
           q = Range("N" & i4).Value
           f = Range("r" & i4).Value
           If (q = "off" Or q = "Off" Or q = "OFF") = True And (f = d) = True And (Range("p" & i4).Value <> "0") = True Then
               Range("s" & i3) = "Resource Utilization Error"
               Range("n" & i3, "s" & i3).Interior.Color = RGB(255, 0, 0)
           End If
       Next i4
    End If
Next i3
End Sub
Sub msg()
 Dim dar() As Variant
 Dim j3, y, strMessage, strMessage2 As Variant
 Sheets("Report").Select
 r3 = Range("a1").SpecialCells(xlCellTypeLastCell).Row
 For i3 = 1 To r3 'changed to start at row 2, in row 1 there are headers I guess
  If (Range("E" & i3).Interior.Color = RGB(255, 0, 0)) = True Then
    ReDim Preserve dar(j3)
    dar(j3) = Range(Cells(i3, 1), Cells(i3, 6))
    'store the values from this row only into string
     For y = 1 To 6
         If y = 1 Then
             strMessage = dar(j3)(1, y)
         Else
            strMessage = strMessage & " || " & dar(j3)(1, y)
        End If
    Next y
    j3 = j3 + 1

    'store all previous strings one string, with multiple rows
    If j3 = 1 Then
        strMessage2 = strMessage
    Else
        strMessage2 = strMessage2 & Chr(10) & strMessage 'chr(10) is a line break
    End If

End If
Next i3
If Not IsEmpty(strMessage2) Then
    MsgBox strMessage2, Title:="Red data"
End If
Dim t As Long
Dim a As Variant
t = GetTickCount
For i = 1 To 1000000
a = a + 1
Next
MsgBox GetTickCount - t, , "Milliseconds"
End Sub









   Student Name   Subject_1   Subject_2     Subject_3  Total_Student_ hrs
       AA             60           80            90       
       bb             50           30            60
       cc             80           80            100           
Total Subject hrs

Answer 1

As I alluded to in my comment, you have bigger concerns than performance right now. I don't know who said it first, but I've repeated it here many times.

1. Make it work.
2. Make it right.
3. Make it fast.

In that order.

Let's see what we can do to make this code right. I'll try to be gentle, but prepare yourself. This might be rough to hear at times.

---

You used Option Explicit. That's good. Unfortunately, that's more or less where the good ends.

Public s, c, r2, r, i, j, k, i3, i1, i2, r1, j1, j2, i4, r3, sum As Long

1. This doesn't do what you think it does. The only variable declared as a Long here is the very last one (sum). The rest are declared as Variants. Properly declaring them as Long types will remove some overhead.

   Public s As Long, c As Long, r2 As Long ' etc.
   

   but don't do that either. Make all of these Private and declare them on their own lines.

   Private s As Long
   Private c As Long
   

2. How is anyone, including yourself 6 months from now supposed to know what these variables represent? Naming is one of the hardest things in computer science, but it's also one of the most important. Variables should be descriptive enough to understand what data they hold at a glance and never should you number them. Never. If you think you need to number a variable, you likely need to restrict another variables scope, extract a function/sub, or add a loop.

   r and c stand for row and column so what not just say so? You'll save yourself a ton of grief later. (I've not dug far enough into the code at this time to recommend better names for the others.)

---

On Error Resume Next
    Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0

This is not error handling. This is swallowing errors and telling your code "It's okay, just run with it. It's cool. Don't worry that we have the wrong worksheet..."

A proper error handler looks like this.

Public Sub Foo()
On Error GoTo ErrHandler

    ' do something that might fail

    Exit Sub

CleanExit:

    Application.EnableEvents = True
    Application.ScreenUpdating = True

ErrHandler:

    ' do something to actually handle the error and Resume Next OR

    ' if you can't recover then

    Resume CleanExit

---

This also doesn't do what you think it does and is a big bug waiting to peek up its ugly head.

With ws
    Cells(1, 1).Value = "Release"

An unqualified call to Cells will implicitly work on the ActiveSheet, whatever it may be. What I believe you meant to do is this.

With ws
    .Cells(1,1).Value = "Release"

Which is a really good reason to not abuse the With statement like you have here. Just explicitly call this on ws and be done with it.

ws.Cells(1,1).Value = "Release"
ws.Cells(1,2).Value = "Project ID"
' ...

Yes it's more typing. Get over it. It will save you headaches down the road. I promise.

---

wh = ws.Name

Okay, so wh is the source worksheet's name. Change wh accordingly.

---

r = Worksheets(wh).Range("c5").SpecialCells(xlCellTypeLastCell).Row

You already have a reference to that worksheet stored in ws (which will henceforth be referred to as sourceSheet by the way), there's no reason to get the worksheet from the collection via its name.

row = ws.Range("C5").SpecialCells(xlCellTypeLastCell).Row
row = row - 1                                              ' To remove the total row which may not be required

You can also save yourself an entire line of code by simply subtracting one from that value right now instead of waiting. Keep the comment. It's a good one, but don't try to right align your comments like this. The second it gets copy/pasted anywhere you'll lose the alignment and waste your time trying to line it back up.

row = ws.Range("C5").SpecialCells(xlCellTypeLastCell).Row - 1 ' subtract one to remove the total row

---

Okay, so here's an actual performance improvement for you. Copy/Paste is slow. Only use it if you're copying a big range of data all at once. Here you're copying one cell at a time to a new location.

        For i = 5 To r
            Worksheets(wh).Cells(i, 1).Copy Destination:=Sheets("Report").Range("A" & j1)
            Worksheets(wh).Cells(i, 2).Copy Destination:=Sheets("Report").Range("b" & j1)
            Worksheets(wh).Cells(i, 6).Copy Destination:=Sheets("Report").Range("c" & j1)
            Worksheets(wh).Cells(i, 10).Copy Destination:=Sheets("Report").Range("d" & j1)
            Worksheets(wh).Cells(i, 4).Copy Destination:=Sheets("Report").Range("g" & j1)
            Call cal
            j1 = j1 + 1
        Next i

So, just set the destination's value instead.

    With Worksheets("Report")
        .Range("A" & j1).Value = ws.Cells(i, 1).Value
        .Range("B" & j1).Value = ws.Cells(i, 2).Value
        .Range("C" & j1).Value = ws.Cells(i, 10).Value
        ' etc
    End With

While you're at it, limit the scope of the j1 and j variables. You have them declared at the module scope. They're not used outside of this procedure, so declare them inside this procedure. (And for the love of clean code give them a half decent name.)

---

Again, the names cousin... the names.... You have two subroutines here. One is named cal the other is named cal1. I'm not even going to bother trying to figure out how they differ. You know, so you tell me by giving them descriptive names.

Nevermind. I see exactly how they differ. They don't.

Sub cal()
   For k = 13 To c
       sum = sum + Worksheets(wh).Cells(i, k)
    Next k
    i1 = i1 + 1
    Worksheets("Report").Range("e" & i1).Value = sum
    sum = 0
    Worksheets("Report").Range("h" & i1).Value = wh
   End Sub
   Sub cal1()
   For s = 5 To r
       sum = sum + Worksheets(wh).Cells(s, j)
    Next s
    Worksheets("Report").Range("q" & i2).Value = sum
     sum = 0
    Worksheets("Report").Range("r" & i2).Value = wh
    i2 = i2 + 1
    End Sub

What you need is a single subroutine that takes in some arguments.

Sub Calculate(ByVal startIndex As Long, ByVal endIndex As Long, ByVal sumTarget As Range, ByVal nameTarget As Range)
    Dim k As Long
    For k = startIndex To endIndex
       sum = sum + sourceSheet.Cells(i, k)
    Next k

    sumTarget.Value = sum
    sum = 0
    nameTarget.Value = wh

End Sub

---

You've extracted no less than 5 subroutines from your main routine already, why is all this looping logic mucking up your main routine anyway? Extract anther subroutine. In fact, extract subroutines everywhere. Everywhere. Stop repeating yourself. Pass parameters. Restrict your variable scope.

And that's just your first MainStart routine... I ran out of time to touch on the rest of this. I'm frustrated with this code, and I don't even have to maintain it. I'm sorry if that was harsh, but this has so far to go yet that I just can't think about it anymore.

---

I apologize for my frustration. I lost my head there for a moment. You indicated in the comments that you're a beginner. I should have guessed as much, but assumed that you thought you were more advanced than you are. I made an ass of myself. You need to get a grip on some basics and unfortunately I don't have the time to explain it all myself. However, I can refer you to some great articles by Chip Pearson. I don't know a single Professional VBA dev that hasn't referred to his work while they were learning, I'm sure it will do you well too.

• Understanding Scope
• Passing Variables ByRef and ByVal
• Optional Arguments
• Macros vs. Function
• Writing Your Own Functions in VBA

Answer 2

Thanks for posting this wonderful code! I copied your code into a new VBA project, and ran Rubberduck code inspections. There were a few false positives (working on it), but if I remove them I'm still left with all these:

Suggestion: Instruction contains multiple declarations - VBAProject.Module1, line 182
Suggestion: Instruction contains multiple declarations - VBAProject.Module1, line 157
Suggestion: Instruction contains multiple declarations - VBAProject.Module1, line 4
Suggestion: Instruction contains multiple declarations - VBAProject.Module1, line 2
Suggestion: Member 'msg' is implicitly Public - VBAProject.Module1, line 180
Suggestion: Member 'Onoffuti' is implicitly Public - VBAProject.Module1, line 156
Suggestion: Member 'redu' is implicitly Public - VBAProject.Module1, line 130
Suggestion: Member 'aling' is implicitly Public - VBAProject.Module1, line 122
Suggestion: Member 'calcheck' is implicitly Public - VBAProject.Module1, line 95
Suggestion: Member 'cal1' is implicitly Public - VBAProject.Module1, line 86
Suggestion: Member 'cal' is implicitly Public - VBAProject.Module1, line 77
Suggestion: Member 'MainStart' is implicitly Public - VBAProject.Module1, line 6
Error: Variable 'strNameSurname3' is never assigned - VBAProject.Module1, line 135
Error: Variable 'strNameSurname4' is never assigned - VBAProject.Module1, line 136
Error: Variable 'strMessage' is never assigned - VBAProject.Module1, line 182
Error: Variable 'strMessage2' is never assigned - VBAProject.Module1, line 182
Error: Variable 'wd' is never assigned - VBAProject.Module1, line 4
Hint: Variable 'strNameSurname3' is never used - VBAProject.Module1, line 135
Hint: Variable 'strNameSurname4' is never used - VBAProject.Module1, line 136
Hint: Variable 'strMessage' is never used - VBAProject.Module1, line 182
Hint: Variable 'strMessage2' is never used - VBAProject.Module1, line 182
Hint: Variable 'wd' is never used - VBAProject.Module1, line 4
Warning: Use of obsolete Call statement - VBAProject.Module1, line 74
Warning: Use of obsolete Call statement - VBAProject.Module1, line 72
Warning: Use of obsolete Call statement - VBAProject.Module1, line 71
Warning: Use of obsolete Call statement - VBAProject.Module1, line 70
Warning: Use of obsolete Call statement - VBAProject.Module1, line 69
Warning: Use of obsolete Call statement - VBAProject.Module1, line 63
Warning: Use of obsolete Call statement - VBAProject.Module1, line 55
Suggestion: Variable 'strMessage' is implicitly Variant - VBAProject.Module1, line 182
Suggestion: Variable 'y' is implicitly Variant - VBAProject.Module1, line 182
Suggestion: Variable 'j3' is implicitly Variant - VBAProject.Module1, line 182
Suggestion: Variable 'q' is implicitly Variant - VBAProject.Module1, line 157
Suggestion: Variable 'd' is implicitly Variant - VBAProject.Module1, line 157
Suggestion: Variable 'p' is implicitly Variant - VBAProject.Module1, line 157
Suggestion: Variable 'ws' is implicitly Variant - VBAProject.Module1, line 4
Suggestion: Variable 'r3' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'i4' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'j2' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'j1' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'r1' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'i2' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'i1' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'i3' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'k' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'j' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'i' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'r' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'r2' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 'c' is implicitly Variant - VBAProject.Module1, line 2
Suggestion: Variable 's' is implicitly Variant - VBAProject.Module1, line 2

---

• Instruction contains multiple declarations - whenever you declare multiple variables on a single line, you're hindering readability and making it harder to maintain your code.
• Variable 'name' is implicitly Variant - @RubberDuck's answer pointed it out, but if you're not explicitly specifying a type for a variable, it implicitly gets declared as a Variant; it won't change how your code runs, but it makes it harder to tell who's supposed to be what... especially with names like that.
• Member 'name' is implicitly Public - If an access modifier isn't specified, module members (procedures) are Public by default. That's potentially confusing, because in most other languages module members are private by default - hence, it's a potential maintainability issue; being explicit about access modifiers eliminates this problem. Also, procedures that are only used inside a module should be Private.
• Use of obsolete Call statement - VBA has quite a bit of history, and some keywords exist only to support legacy code written in older versions: the Call statement is one of such. If you need to call a method, just call that method - drop the Call keyword and the parentheses, and you're done.
• Variable 'name' is never assigned - some variables are never assigned a value; if they're referred to (good thing they're not), then you almost certainly have a bug. Otherwise, you have dead code.
• Variable 'name' is never used - some variables are never referred to; if they're also assigned (good thing they're not), then the assigned value is never used, and you have dead code.

---

The indentation is insufficient, which makes the code harder to read. A good rule of thumb would be that whenever you're writing code inside a code block (like between Sub...End Sub or If...End If), you should add an indentation level (tab). Indentation is also inconsistent - that's even worse, it completely defeats the whole purpose of indentation - the indent of If (block begin) should should match the indent of End If (block end).

Avoid extraneous indentation, too - there's no reason for the For block to be 2 tabs right of the r1 assignment; both should actually be lined up:

 r1 = Range("n1").SpecialCells(xlCellTypeLastCell).Row
        For i2 = 2 To r1

---

It looks like the CalCheck procedure (whatever that means) could be completely replaced with Excel formulae and conditional formattings - VBA isn't a silver bullet (I swear!), sometimes a good old formula works much better & faster!