Excel VBA如果然后循环条件

我一直在为此挣扎几天。 任何帮助将不胜感激！

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

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

例如，如果Query_A有1个确切的结果，然后Query_Z有1个确切的结果，那么这将是总共2个有1个结果的查询。

我目前正在尝试使用循环与if语句，但我很茫然。

下面是一些示例数据和我期望的输出： 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 

这应该做的！