MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.
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 |
---|---|---|---|
E2 + M2 = N2 == 10:02 AM | 3 | 19 | |
Find and Replace Function not working in Excel | 13 | 41 | |
how to transpose my example data using VBA | 9 | 31 | |
Excel 2016 vba task to have certain column appear in certain rows | 20 | 22 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
12 Experts available now in Live!