Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.
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
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Function CountData(item As String, table As Range) As Integer
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...
....
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
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.