Excel VBA如果然後循環條件

Question

我一直在掙扎着這幾天。任何幫助將不勝感激！

這很難解釋，所以我會盡我所能。

我試圖做的是計算每個查詢有結果的數量，然後根據該結果計數分類。

例如，如果Query_A具有1個精確的結果，然後Query_Z具有1分精確的結果，那麼這將是一個總2個查詢具有1個結果的。

我目前正在嘗試使用循環使用，如果再聲明，但我不知所措。

下面是一些示例數據和我期望的輸出：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 

，這應該做的！