Question

我几天都在努力解决这个问题。非常感谢任何帮助！

很难解释，所以我会尽我所能。

我要做的是计算每个查询的结果数，然后根据结果计数对它们进行分类。

例如，如果Query_A有1个精确结果，然后Query_Z有1个精确结果，那么总共有2个查询有1个结果。

我正在尝试使用Loop with if then语句，但我不知所措。

以下是一些示例数据和我希望的输出：Query_Example_Data_and_Results.xlsx - 这不是我真正的电子表格，因为它是数千行数据和非常大的文件大小。

下面的代码确实提取了查询计数（删除了查询对方），但没有给出查询结果计数..我会提供我的代码尝试，但我知道我甚至不接近......所以我已经取消了我失败的尝试，希望我足够清楚，能够朝着正确的方向转向。

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

提前谢谢！

Answer 1

根据您的示例，此代码将完成此任务：

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

评论后修改： 改变这三个：

将+28添加到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

只需将位置更改为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

准备表更改范围

Sub PrepTable(ws As Worksheet)
    ws.Range("B30:B40").ClearContents
End Sub

这应该做！

Excel VBA If Then循环条件

1 个答案: