Excel VBA If Then Loop conditions - excel

Question

I've been struggling with this for a few days. Any help would greatly be appreciated!
It's difficult to explain, so I'll do my best.
What I'm trying to do is count the number of results each query has and then categorize them based on that result count.
For example if Query_A has 1 exact result and then Query_Z has 1 exact result then that would be a total of 2 queries that have 1 result.
I'm currently trying to use Loop with if then statements, but I'm at a loss.
Here is some example data and the output I was hoping for: Query_Example_Data_and_Results.xlsx - This is not my real spreadsheet as it is thousands of rows of data and a very large file size.
The code below does pull the query count (removing the query dupes), but does not give the query result count.. I would have provide my code attempts, but I know I'm not even close... So I have removed my failed attempts hoping I'm being clear enough to get steered in the right direction.
Sub Query_Count()
G_40 = 0
Query = ""
Application.StatusBar = " ~~ ~~ QUERY COUNT ~~ RUNNING ~~ ~~ " & x
x = 2
Do Until Sheets(1).Cells(x, 1) = ""
If Sheets(1).Cells(x, 9) = "Yes" Then
If Query <> Sheets(1).Cells(x, 1) Then
G_40 = G_40 + 1
End If
End If
Query = Sheets(1).Cells(x, 1)
x = x + 1
Loop
Application.StatusBar = "DONE RUNNING QUERY COUNT OF " & x & " ROWS!"
G = 40
Sheets(3).Cells(G, 7) = G_40 'query_count:
End Sub
Thank you in advance!

Answer 1

Based on your Example this code will do the job:
Option Explicit
Sub getResults()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet, lr&
Set ws1 = ThisWorkbook.Sheets("Example_Query_Data")
Set ws2 = ThisWorkbook.Sheets("Example_Results")
lr = ws1.Range("A" & Rows.count).End(xlUp).Row
Dim arr() As String, i&, j&, cnt&
Dim varr() As String
cnt = 0
ReDim arr(lr - 2)
For i = 2 To lr
arr(i - 2) = CStr(ws1.Range("A" & i).Value) ' fill array
Next i
Call RemoveDuplicate(arr) 'remove duplicate
ReDim varr(0 To UBound(arr), 0 To 1)
For i = LBound(arr) To UBound(arr)
varr(i, 0) = arr(i)
varr(i, 1) = getCount(arr(i), ws1, j, lr)
Next i
Call PrepTable(ws2)
Call UpdateTable(ws2, ws1, varr, j, lr) ' Update table
Application.ScreenUpdating = True
End Sub
Function getCount(qName$, ByRef ws1 As Worksheet, ByRef i&, lr&)
Dim count&
count = 0
For i = 2 To lr
If (StrComp(CStr(ws1.Range("A" & i).Value), qName, vbTextCompare) = 0) And _
(StrComp(CStr(ws1.Range("C" & i).Value), "Yes", vbTextCompare) = 0) Then count = count + 1
Next i
getCount = count ' return count
End Function
Sub UpdateTable(ByRef ws As Worksheet, ByRef ws2, ByRef arr() As String, ByRef i&, lr&)
Dim tblIter&
For tblIter = 2 To 12
For i = LBound(arr) To UBound(arr)
If arr(i, 1) = tblIter - 1 Then
ws.Range("B" & tblIter).Value = ws.Range("B" & tblIter).Value + 1
End If
Next i
Next tblIter
Call ElevenAndMore(ws, ws2, arr, lr, i)
End Sub
Sub PrepTable(ws As Worksheet)
ws.Range("B2:B12").ClearContents
End Sub
Sub ElevenAndMore(ByRef ws As Worksheet, ByRef ws2, ByRef arr() As String, lr&, ByRef i)
Dim cnt&, j&
cnt = 0
For i = LBound(arr) To UBound(arr)
For j = 1 To lr
If StrComp(CStr(ws2.Range("A" & j).Value), arr(i, 0), vbTextCompare) = 0 Then
cnt = cnt + 1
End If
Next j
If cnt > 10 Then ws.Range("B12").Value = ws.Range("B12").Value + 1
cnt = 0
Next i
End Sub
Sub RemoveDuplicate(ByRef StringArray() As String)
Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
If (Not StringArray) = True Then Exit Sub ' is empty?
lowBound = LBound(StringArray)
UpBound = UBound(StringArray)
ReDim tempArray(lowBound To UpBound)
cur = lowBound ' first item
tempArray(cur) = StringArray(lowBound)
For A = lowBound + 1 To UpBound
For B = lowBound To cur
If LenB(tempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > cur Then cur = B: tempArray(cur) = StringArray(A)
Next A
ReDim Preserve tempArray(lowBound To cur) ' reSize
StringArray = tempArray ' copy
End Sub
Post-Comment Edit:
Change these three:
Add +28 to the tblIter
Sub UpdateTable(ByRef ws As Worksheet, ByRef ws2, ByRef arr() As String, ByRef i&, lr&)
Dim tblIter&
For tblIter = 2 To 12
For i = LBound(arr) To UBound(arr)
If arr(i, 1) = tblIter - 1 Then
ws.Range("B" & tblIter + 28).Value = ws.Range("B" & tblIter + 28).Value + 1
End If
Next i
Next tblIter
Call ElevenAndMore(ws, ws2, arr, lr, i)
End Sub
Simply change location to B40
Sub ElevenAndMore(ByRef ws As Worksheet, ByRef ws2, ByRef arr() As String, lr&, ByRef i)
Dim cnt&, j&
cnt = 0
For i = LBound(arr) To UBound(arr)
For j = 1 To lr
If StrComp(CStr(ws2.Range("A" & j).Value), arr(i, 0), vbTextCompare) = 0 Then
cnt = cnt + 1
End If
Next j
If cnt > 10 Then ws.Range("B40").Value = ws.Range("B40").Value + 1
cnt = 0
Next i
End Sub
And prep table change range
Sub PrepTable(ws As Worksheet)
ws.Range("B30:B40").ClearContents
End Sub
and this should do!