Application.ScreenUpdating
after the Dim statements and
Application.ScreenUpdating
before the msgbox statement at the end,
that just doing this will reduce the time by half.
Sub Total()
Dim WSV As Worksheet
Dim WST As Worksheet
Dim Rng As Range
Dim RowV As Long
Dim ColV As Long
Dim RowT As Long
Dim ColT As Long
Dim MaxCol As Long
Dim Typee As String
Dim Totall As Long
Dim GTotal As Long
Dim FirstNumber As Long
Dim I As Long
Dim J As Long
Set WSV = Sheets("Validation")
WSV.Copy after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
Set WSV = ActiveSheet
Set Rng = WSV.Range("A1:BW65536")
Set WST = Sheets("Total")
RowT = 2
ColT = 1
GTotal = 0
Do
Rng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftToLeft
If Rng.Cells(2, 1) = "" Then
Rng.Range("2:2").EntireRow.Delete
End If
FirstNumber = Rng.Cells(2, 1)
Totall = 0
With Rng
Set C = .Find(What:=FirstNumber, LookIn:=xlValues, lookat:=xlWhole)
If Not C Is Nothing Then
firstAddress = C.Address
firstType = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5)
Do
Totall = Totall + 1
GTotal = GTotal + 1
Typee = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5)
Set C = .FindNext(C)
NewType = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5)
Loop While Not C Is Nothing And C.Address <> firstAddress And firstType = NewType
WST.Cells(RowT, ColT) = FirstNumber
WST.Cells(RowT, ColT + 1) = Typee
WST.Cells(RowT, ColT + 2) = Totall
DoEvents
'Clear Cells from Range
Set C = .Find(What:=FirstNumber, LookIn:=xlValues, lookat:=xlWhole)
If Not C Is Nothing Then
firstAddress = C.Address
firstType = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5)
Do
Rng.Cells(C.row, C.Column) = ""
Rng.Cells(C.row, (C.Column + 1)).Value = ""
Set C = .FindNext(C)
On Error Resume Next
NewType = Mid(Rng.Cells(C.row, (C.Column + 1)), 1, 5)
Loop While Not C Is Nothing And C.Address <> firstAddress And firstType = NewType
Err.Clear
End If
ColT = ColT + 5
If ColT > 29 Then
ColT = 1
RowT = RowT + 1
End If
End If
End With
Loop While FirstNumber <> 0
Application.DisplayAlerts = False
WSV.Delete
Application.DisplayAlerts = True
WST.Activate
MsgBox ("Total completed for " & GTotal & " unique items")
End Sub
SpeedData.xls
Sub x()
Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long
Sheets("Validation").Activate
On Error Resume Next
Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeft
On Error GoTo 0
vIn = Range("A1").CurrentRegion.Value
ReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 2)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 1 To UBound(vIn, 1)
For j = 1 To UBound(vIn, 2) - 1 Step 2
If Not .Exists(vIn(i, j)) Then
n = n + 1
vOut(n, 1) = vIn(i, j)
vOut(n, 2) = Left(vIn(i, j + 1), 5)
.Add vIn(i, j), n
End If
Next j
Next i
End With
Sheets("Total").Range("A1").Resize(n, 2) = vOut
End Sub
Sub x()
Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long
Sheets("Validation").Activate
On Error Resume Next
Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeft
On Error GoTo 0
vIn = Range("A1").CurrentRegion.Value
ReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 2)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 2 To UBound(vIn, 1)
For j = 1 To UBound(vIn, 2) - 1 Step 2
If Not .Exists(vIn(i, j)) Then
n = n + 1
vOut(n, 1) = vIn(i, j)
vOut(n, 2) = Left(vIn(i, j + 1), 5)
.Add vIn(i, j), n
End If
Next j
Next i
End With
p = WorksheetFunction.RoundUp(n / 3, 0)
With Sheets("Total").Range("A2")
.CurrentRegion.Clear
.Offset(-1).Resize(, 6).Value = Array("Number", "Type", "Number", "Type", "Number", "Type")
.Resize(n, 2) = vOut
.Offset(p).Resize(n - p, 2).Cut .Offset(, 2)
.Offset(p, 2).Resize(n - 2 * p, 2).Cut .Offset(, 4)
End With
End Sub
Sub x()
Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long
With Sheets("Validation")
On Error Resume Next
.Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeft
On Error GoTo 0
vIn = .Range("A1").CurrentRegion.Value
End With
ReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 3)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 2 To UBound(vIn, 1)
For j = 1 To UBound(vIn, 2) - 1 Step 2
If Not .Exists(vIn(i, j)) Then
n = n + 1
vOut(n, 1) = vIn(i, j)
vOut(n, 2) = Left(vIn(i, j + 1), 5)
vOut(n, 3) = 1
.Add vIn(i, j), n
Else
vOut(.Item(vIn(i, j)), 3) = vOut(.Item(vIn(i, j)), 3) + 1
End If
Next j
Next i
End With
p = WorksheetFunction.RoundUp(n / 3, 0)
With Sheets("Total").Range("A2")
.CurrentRegion.Clear
.Offset(-1).Resize(, 9).Value = Array("Number", "Type", "Count", "Number", "Type", "Count", "Number", "Type", "Count")
.Resize(n, 3) = vOut
.Offset(p).Resize(n - p, 3).Cut .Offset(, 3)
.Offset(p, 3).Resize(n - 2 * p, 3).Cut .Offset(, 6)
End With
End Sub
Sub x()
Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long, nCol As Long
nCol = Application.InputBox("How many sets of columns for the results (each set has three columns)?", Type:=1)
With Sheets("Validation")
On Error Resume Next
.Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeft
On Error GoTo 0
vIn = .Range("A1").CurrentRegion.Value
End With
ReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 3)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 2 To UBound(vIn, 1)
For j = 1 To UBound(vIn, 2) - 1 Step 2
If Not .Exists(vIn(i, j)) Then
n = n + 1
vOut(n, 1) = vIn(i, j)
vOut(n, 2) = Left(vIn(i, j + 1), 5)
vOut(n, 3) = 1
.Add vIn(i, j), n
Else
vOut(.Item(vIn(i, j)), 3) = vOut(.Item(vIn(i, j)), 3) + 1
End If
Next j
Next i
End With
p = WorksheetFunction.RoundUp(n / nCol, 0)
With Sheets("Total")
.UsedRange.Clear
With .Range("A1")
.Resize(, 3).Value = Array("Number", "Type", "Count")
.Offset(1).Resize(n, 3) = vOut
For j = 1 To nCol - 1
.Offset(, j * 4).Resize(, 3).Value = Array("Number", "Type", "Count")
.Offset(p + 1, (j - 1) * 4).Resize(n - (p * j), 3).Cut .Offset(1, j * 4)
Next j
End With
End With
End Sub
Sub x()
Dim oDic As Object, vOut(), vIn(), vOut2()
Dim i As Long, j As Long, k As Long, n As Long, p As Long, nCol As Long, r As Long
nCol = Application.InputBox("How many sets of columns for the results (each set has three columns)?", Type:=1)
With Sheets("Validation")
On Error Resume Next
.Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeft
On Error GoTo 0
vIn = .Range("A1").CurrentRegion.Value
End With
ReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 3)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 1 To UBound(vIn, 1)
For j = 1 To UBound(vIn, 2) - 1 Step 2
If Not .Exists(vIn(i, j)) Then
n = n + 1
vOut(n, 1) = vIn(i, j)
vOut(n, 2) = Left(vIn(i, j + 1), 5)
vOut(n, 3) = 1
.Add vIn(i, j), n
Else
vOut(.Item(vIn(i, j)), 3) = vOut(.Item(vIn(i, j)), 3) + 1
End If
Next j
Next i
End With
p = WorksheetFunction.RoundUp(n / nCol, 0)
With Sheets("Total")
.Activate
.UsedRange.Clear
With .Range("A1")
.Resize(, 3).Value = Array("Number", "Type", "Count")
For r = 1 To nCol
ReDim vOut2(1 To p, 1 To 3)
For i = (r - 1) * p + 1 To (r - 1) * p + p
k = k + 1
For j = 1 To 3
vOut2(k, j) = vOut(i, j)
Next j
Next i
.Offset(, (r - 1) * 4).Resize(, 3).Value = Array("Number", "Type", "Count")
.Offset(1, (r - 1) * 4).Resize(p, 3) = vOut2
k = 0
Next r
End With
End With
End Sub
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
How to change associated macro so it asks for folder rather than using hardcoded folder? | 4 | 36 | |
Struggling to Lock and grey out cells using VBA. Help please! | 8 | 27 | |
Problem to With line | 4 | 42 | |
Create Files based on Cell Values in a Range in Excel | 12 | 19 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
16 Experts available now in Live!