This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.
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
SpeedData.xls
Function CountData...
....
x()
End Function
Long
Function CountData(item As String, table As Range) As Integer
x()
Dim nCount As Integer
Dim strTmp As String
Dim nI As Integer
Dim nJ As Integer
For nI = 1 To table.Columns.Count
For nJ = 1 To table.Columns(nI).Rows.Count
strTmp = table.Columns(nI).Rows(nJ).Value
If (strTmp <> "") And (Left(strTmp, 5) = item) Then
nCount = nCount + 1
End If
Next nJ
Next nI
CountData = nCount
End Function
Function CountData(item As String, table As Range) As Integer
x
Dim nCount As Integer
Dim strTmp As String
Dim nI As Integer
Dim nJ As Integer
For nI = 1 To table.Columns.Count
For nJ = 1 To table.Columns(nI).Rows.Count
strTmp = table.Columns(nI).Rows(nJ).Value
If (strTmp <> "") And (Left(strTmp, 5) = item) Then
nCount = nCount + 1
End If
Next nJ
Next nI
CountData = nCount
End Function
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")
[b].Resize(, 4).Value = Array("Number", "Type", "Count", "Total Data") 'Long modified[/b] .Offset(1).Resize(n, 3) = vOut
For j = 1 To nCol - 1
[b].Offset(, j * 4).Resize(, 4).Value = Array("Number", "Type", "Count", "Total Data") 'Long modified[/b] .Offset(p + 1, (j - 1) * 4).Resize(n - (p * j), 3).Cut .Offset(1, j * 4)
Next j
End With
End With
[b]'-------Long added--------------
Dim nC As Long, nR As Long, nCTmp As Long, nVal As Long, strCellVal As String
For nC = 1 To nCol
For nR = 1 To p
nCTmp = (nC - 1) * 4 + 2
strCellVal = Range(Chr(64 + nCTmp) & Trim(Str(nR + 1))).Value
If strCellVal <> "" Then
nVal = CountData(strCellVal, Range("TABLEDATA"))
nCTmp = nCTmp + 2
Range(Chr(64 + nCTmp) & Trim(Str(nR + 1))).Value = nVal
End If
Next nR
Next nC[/b]
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(, 4).Value = Array("Number", "Type", "Count", "Total 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(, 4).Value = Array("Number", "Type", "Count", "Total Count")
.Offset(1, (r - 1) * 4).Resize(p, 3) = vOut2
k = 0
Next r
End With
End With
'Build the data dictionary
Dim oDicTmp As Object
Set oDicTmp = CreateObject("Scripting.Dictionary")
Dim strTmp As String
Dim nI As Integer
Dim nJ As Integer
For nI = 1 To Range("TABLEDATA").Columns.Count
For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count
strTmp = Range("TABLEDATA").Columns(nI).Rows(nJ).Value
If strTmp <> "" Then
strTmp = Left(strTmp, 5)
If Not (oDicTmp.Exists(strTmp)) Then
oDicTmp.Add strTmp, 1
Else
oDicTmp.item(strTmp) = oDicTmp.item(strTmp) + 1
End If
End If
Next nJ
Next nI
'Start counting process
Dim nC As Long, nR As Long, nCTmp As Long, nVal As Long, strCellVal As String
For nC = 1 To nCol
For nR = 1 To p
nCTmp = (nC - 1) * 4 + 2
strCellVal = Cells(nR + 1, nCTmp).Value
If strCellVal <> "" Then
If oDicTmp.Exists(strCellVal) Then
nVal = oDicTmp(strCellVal)
Else
nVal = 0
End If
nCTmp = nCTmp + 2
Cells(nR + 1, nCTmp).Value = nVal
End If
Next nR
Next nC
End Sub
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
Please try to use following function to achieve the result:
Open in new window
I also enclosed the file here for your reference.
I hope it helps.
Long
SpeedData.xls