需要在VBA中提取基於一個條件來提取唯一值的幫助

Question

我有一個工作代碼，可以從工作表中提取不同的值，但它只給出了不同值的總和。 我需要它在一定的條件下工作，目前我有13種不同的條件，每種條件都應該將特定值填入另一張表上的特定單元格。

例如 條件1：46130288，所述不同值的結果應該被填充到表KPI細胞D3 條件2：55202136，所述不同值的結果應該被填充到表KPI細胞D6。

總共不同值的工作代碼如下所示：

Sub CntOrder() 
    Dim Uni As Collection, cl As Range, LpRange As Range 
    Dim clswfrm As Range, clswcst As Range, myRng As Range 
    Dim TotUni As Long 
    '************* 
    Set myRng = Sheets("957").[E:E] 'define your sheet/range 
    '************* 
    On Error Resume Next 
    Set clswfrm = myRng.SpecialCells(xlFormulas) 
    Set clswcst = myRng.SpecialCells(xlConstants) 
    Set myRng = Nothing 'free up memory 
    On Error GoTo 0 
    If clswfrm Is Nothing And clswcst Is Nothing Then 
     MsgBox "No Unique Cells" 
     Exit Sub 
    ElseIf Not clswfrm Is Nothing And Not clswcst Is Nothing Then 
     Set LpRange = Union(clswcst, clswfrm) 
    ElseIf clswfrm Is Nothing Then Set LpRange = clswcst 
    Else: Set LpRange = clswfrm 
    End If 
    Set clswfrm = Nothing: Set clswcst = Nothing 'Free up memory 
    Set Uni = New Collection 
    On Error Resume Next 
    For Each cl In LpRange 
     Uni.Add cl.Value - 2, CStr(cl.Value) 'assign unique key string 
    Next cl 
    On Error GoTo 0 
    Set LpRange = Nothing 'free up memory 
    TotUni = Uni.Count 
    Set Uni = Nothing ''free up memory 
    Range("D2") = TotUni 'Work with the Unique value total here (replace msgbox) 
End Sub 

希望有人能夠幫助我在得到上面的代碼來檢查表（「957」），範圍（「T：T」。 ）待條件滿足後

Answer 1

希望這會讓你開始。

Sub CntOrder() 
    Dim Uni As Object 
    Dim r As Range, Target As Range 

    With Sheets("957") 
     Set Target = Intersect(.Columns("E"), .UsedRange) 'Set the Target range to the used portion of column E 
    End With 

    If Target Is Nothing Then 
     MsgBox "No Unique Cells" 
     Exit Sub 
    End If 

    Set Uni = CreateObject("Scripting.Dictionary") 

    For Each r In Target 'assign unique key & count occurence 
     Uni(r.Value) = Uni(r.Value) + 1 'The key is a variant type 
    Next 

    With Sheets("Sheet KPI") 
     .Range("D2") = Uni.Count 
     .Range("D3").Resize(Uni.Count).Value = Application.Transpose(Uni.Keys) 'Assign the unique value 
     .Range("E3").Resize(Uni.Count).Value = Application.Transpose(Uni.Items) ' Assign the counts of each unique vaule 
    End With 
End Sub