Excel VBA If Then 循环条件

Excel VBA If Then Loop conditions

提问by CodeCore

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.

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

I'm currently trying to use Loop with if then statements, but I'm at a loss.

我目前正在尝试将 Loop 与 if then 语句一起使用，但我不知所措。

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.

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

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!

先感谢您！

采纳答案by CodeCore

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

将 +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

Simply change location to B40

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

这应该可以！