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