VBA：计数时间一对值出现

Question

从中生成：

：

我有此代码：

Sub missing()
Dim ws, wsOut As Worksheet
Set ws = ActiveWorkbook.Sheets("Table1")
Set wsOut = ActiveWorkbook.Sheets("output")

lastRow = ws.Range("G" & Rows.Count).End(xlUp).Row
lastRowOut = wsOut.Range("G" & Rows.Count).End(xlUp).Row + 1

For i = 1 To lastRow
    If (ws.Cells(i, 10).Value = "") _
    And _
    ((ws.Cells(i, 7).Value = "Peking") Or _
    (ws.Cells(i, 7).Value = "Tokio") Or _
    (ws.Cells(i, 7).Value = "London")) _
    And _
    ((ws.Cells(i, 8).Value = "A") Or _
    (ws.Cells(i, 8).Value = "B") Or _
    (ws.Cells(i, 8).Value = "C")) _
    Then
        wsOut.Range("B" & lastRowOut & ":C" & lastRowOut).Value = ws.Range("G" & i & ":H" & i).Value
        wsOut.Range("A" & lastRowOut).Value = i
        lastRowOut = lastRowOut + 1
    End If
Next i
End Sub

我尝试实现一个代码以生成一个代码，此外此输出以红色标记：

因此，我正在尝试计算并列出每对发生的一对。我试图将“ Countifs”实现到IF-Stategent中，但失败了。实际的表有超过40个条目在“城市”，“部门”中有10多个条目，总共有6.000多个条目。如果有人可以帮助我这样做，那会很高兴。预先感谢！

Answer 1

正如您在评论中提到的那样，您似乎不知道如何录制宏：您转到“开发人员”功能区（您可能需要先启用它），在第一部分中，您单击“记录宏”，而您只是开始执行要记录的内容（在这种情况下，插入一个枢轴表）。

我刚刚这样做，使用范围“ A1：B8”作为输入并创建您要寻找的枢轴表的类型，并且以下代码会自动创建（当心它是自动添加的代码，它具有很多多余的线，参数，...：可以使用它作为起点，但是尝试通过修改，删除，...部分来学习它非常有用）：

Sub Macro1()
'
' Macro1 Macro
'

'
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Sheet1!R1C1:R8C2", Version:=6).CreatePivotTable TableDestination:= _
        "Sheet1!R2C4", TableName:="PivotTable3", DefaultVersion:=6
    Sheets("Sheet1").Select
    Cells(2, 4).Select
    With ActiveSheet.PivotTables("PivotTable3")
        .ColumnGrand = True
        .HasAutoFormat = True
        .DisplayErrorString = False
        .DisplayNullString = True
        .EnableDrilldown = True
        .ErrorString = ""
        .MergeLabels = False
        .NullString = ""
        .PageFieldOrder = 2
        .PageFieldWrapCount = 0
        .PreserveFormatting = True
        .RowGrand = True
        .SaveData = True
        .PrintTitles = False
        .RepeatItemsOnEachPrintedPage = True
        .TotalsAnnotation = False
        .CompactRowIndent = 1
        .InGridDropZones = False
        .DisplayFieldCaptions = True
        .DisplayMemberPropertyTooltips = False
        .DisplayContextTooltips = True
        .ShowDrillIndicators = True
        .PrintDrillIndicators = False
        .AllowMultipleFilters = False
        .SortUsingCustomLists = True
        .FieldListSortAscending = False
        .ShowValuesRow = False
        .CalculatedMembersInFilters = False
        .RowAxisLayout xlCompactRow
    End With
    With ActiveSheet.PivotTables("PivotTable3").PivotCache
        .RefreshOnFileOpen = False
        .MissingItemsLimit = xlMissingItemsDefault
    End With
    ActiveSheet.PivotTables("PivotTable3").RepeatAllLabels xlRepeatLabels
    ActiveWorkbook.ShowPivotTableFieldList = True
    With ActiveSheet.PivotTables("PivotTable3").PivotFields("City")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable3").PivotFields("Dep")
        .Orientation = xlRowField
        .Position = 2
    End With
    ActiveSheet.PivotTables("PivotTable3").AddDataField ActiveSheet.PivotTables( _
        "PivotTable3").PivotFields("Dep"), "Count of Dep", xlCount
End Sub

顺便说一句：正如您可以从命名“ Pivottable3”，我从第一次尝试中没有成功:-)

Answer 2

计数列对（字典）

• 调整（播放）常数部分中的值。

Option Explicit

Sub CountColumnPairs()
    
    ' 1. Define (adjust) constants.
    
    ' s - Source (read from)
    Const sName As String = "Table1"
    ' Designate the first and second unique column of the range.
    Dim suCols() As Variant: suCols = VBA.Array(2, 3) ' switch for fun
    
    ' d - Destination (write to)
    Const dName As String = "Output"
    Const dFirstCellAddress As String = "A1"
    ' Designate the position of the unique columns (1, 2)
    ' and the count column (0).
    Dim dCols() As Variant: dCols = VBA.Array(1, 2, 0) ' switch for fun
    Const dCountColumnTitle As String = "Appears ""x"" Times"
    
    ' 2. Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' 3. Write the source data to arrays.
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    ' Reference the source range ('srg') ...
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    ' ... and write its number of rows to a variable ('srCount').
    Dim srCount As Long: srCount = srg.Rows.Count
    
    ' Write the values from the unique columns
    ' to 2D one-based (one-column) arrays ('sData1', 'sData2').
    Dim sData1() As Variant: sData1 = srg.Columns(suCols(0)).Value
    Dim sData2() As Variant: sData2 = srg.Columns(suCols(1)).Value
    
    ' 4. Write the unique values and their count to a dictionary ('dict').
    '    In the dictionary, the 'keys' ('Key1') will hold the unique values
    '    from the first unique column, while each corresponding 'item'
    '    ('dict(Key1)') will hold another dictionary whose 'keys' ('Key2')
    '    will hold the values from the second unique column,
    '    while each corresponding 'item' ('dict(Key1)(Key2)')
    '    will hold the count.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") ' main
    dict.CompareMode = vbTextCompare ' case-insensitivity ('A=a')
    
    Dim drCount As Long: drCount = 1 '
    
    Dim Key1 As Variant
    Dim Key2 As Variant
    Dim sr As Long
    
    For sr = 2 To srCount
        Key1 = sData1(sr, 1) ' first column
        If Not dict.Exists(Key1) Then
            Set dict(Key1) = CreateObject("Scripting.Dictionary")
            dict(Key1).CompareMode = vbTextCompare ' case-insensitivity ('A=a')
        End If
        Key2 = sData2(sr, 1) ' second column
        If Not dict(Key1).Exists(Key2) Then drCount = drCount + 1 ' total count
        dict(Key1)(Key2) = dict(Key1)(Key2) + 1 ' each count
    Next sr
    
    ' 5. Write the values from the dictionary
    '    to the destination array ('dData').
    
    ' Define the destination array.
    Dim dcUpper As Long: dcUpper = UBound(dCols)
    Dim dcCount As Long: dcCount = dcUpper + 1
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
        
    ' Write the headers.
    
    Dim sValue As Variant
    Dim dc As Long
    Dim Key1Written As Boolean
    
    For dc = 0 To dcUpper
        Select Case dCols(dc)
        Case 0
            sValue = dCountColumnTitle
        Case 1
            sValue = sData1(1, 1)
        Case 2
            sValue = sData2(1, 1)
        End Select
        dData(1, dc + 1) = sValue
    Next dc
    
    ' Write the data.
    
    Dim dr As Long: dr = 1 ' headers are already written
    
    For Each Key1 In dict.Keys
        For Each Key2 In dict(Key1).Keys
            dr = dr + 1
            For dc = 0 To dcUpper
                Select Case dCols(dc)
                Case 0
                    sValue = dict(Key1)(Key2)
                Case 1
                    sValue = Key1
                Case 2
                    sValue = Key2
                End Select
                dData(dr, dc + 1) = sValue
            Next dc
        Next Key2
    Next Key1
    
    ' 6. Write the results to the destination.
    
    ' Reference the destination worksheet ('dws')...
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    ' ... and clear its cells.
    dws.UsedRange.Clear
    ' Reference the first row of the destination range.
    With dws.Range(dFirstCellAddress).Resize(, dcCount)
        ' Write the values from the destination array to the destination range.
        .Resize(drCount).Value = dData
        ' Apply simple formatting.
        .Font.Bold = True ' first row
        .EntireColumn.AutoFit ' entire columns
    End With
    
    ' Save the workbook.
    'wb.Save
    
    ' 7. Inform to not wonder if the code has run or not.
    
    MsgBox "Column pairs counted.", vbInformation
    
End Sub

Answer 3

不需要VBA。

e2 IS = sort（unique（$ b $ 2：$ c $ 18），{1,2}，{1,1}）
公式
g2 IS = countifs（$ b $ 2：$ b $ 18，index（e2＃,, 1），$ c $ 2：$ c $ 18，index（e2＃，2） ）

vba解决方案：
结果测试过程将保持您的值，也可以在工作表上使用 = sort（countcities（b2：c18），{1,2}，{1,1}）结果是我的第一个解决方案。

Sub Test()

    Dim MyDataRange As Range
    Set MyDataRange = ThisWorkbook.Worksheets("Sheet1").Range("B2:C18")

    Dim Result As Variant
    Result = CountCities(MyDataRange)

End Sub

Public Function CountCities(Target As Range) As Variant

    Dim UniqueValues As Variant
    UniqueValues = WorksheetFunction.Unique(Target)
    ReDim Preserve UniqueValues(1 To UBound(UniqueValues), 1 To 3)
    
    Dim itm As Long
    For itm = 1 To UBound(UniqueValues)
        UniqueValues(itm, 3) = WorksheetFunction.CountIfs(Target.Columns(1), UniqueValues(itm, 1), Target.Columns(2), UniqueValues(itm, 2))
    Next itm
    
    CountCities = UniqueValues

End Function

一个过程中的所有内容：

Public Sub Missing()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Table1")
    
    Dim wsOut As Worksheet
    Set wsOut = ThisWorkbook.Worksheets("output")
    
    Dim lastRow As Long
    lastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row
    
    Dim lastRowOut As Long
    lastRowOut = wsOut.Cells(Rows.Count, 7).End(xlUp).Row + 1
    
    Dim Target As Range
    Set Target = ws.Range(ws.Cells(2, 7), ws.Cells(lastRow, 8))
    
    Dim UniqueValues As Variant
    UniqueValues = WorksheetFunction.Unique(Target)
    ReDim Preserve UniqueValues(1 To UBound(UniqueValues), 1 To 3)
    
    Dim itm As Long
    For itm = 1 To UBound(UniqueValues)
        UniqueValues(itm, 3) = WorksheetFunction.CountIfs(Target.Columns(1), UniqueValues(itm, 1), Target.Columns(2), UniqueValues(itm, 2))
    Next itm
    
    Dim wsOutRange As Range
    Set wsOutRange = wsOut.Cells(lastRowOut, 2).Resize(UBound(UniqueValues), 3)
    
    wsOutRange = UniqueValues
    With wsOut.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsOutRange.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=wsOutRange.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range(wsOutRange.Address)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With

End Sub

新代码不使用 unique 函数：

Public Sub Missing()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Table1")
    
    Dim wsOut As Worksheet
    Set wsOut = ThisWorkbook.Worksheets("output")
    
    Dim lastRow As Long
    lastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row
    
    Dim lastRowOut As Long
    lastRowOut = wsOut.Cells(Rows.Count, 7).End(xlUp).Row + 1
    
    Dim Target As Range
    Set Target = ws.Range(ws.Cells(2, 7), ws.Cells(lastRow, 8))
    
    'New code
    '''''''''
    Dim tmpCol As New Collection
    Dim rw As Range
    For Each rw In Target.Rows
        On Error Resume Next
        tmpCol.Add rw, rw.Cells(1) & rw.Cells(2)
        On Error GoTo 0
    Next rw
     
    Dim UniqueValues As Variant
    ReDim UniqueValues(1 To tmpCol.Count, 1 To 2)
    
    Dim lCntr As Long
    For lCntr = 1 To tmpCol.Count
        UniqueValues(lCntr, 1) = tmpCol(lCntr).Cells(1).Value
        UniqueValues(lCntr, 2) = tmpCol(lCntr).Cells(2).Value
    Next lCntr
    'End of new code
    ''''''''''''''''
    
    'UniqueValues = WorksheetFunction.Unique(Target)
    ReDim Preserve UniqueValues(1 To UBound(UniqueValues), 1 To 3)
    
    Dim itm As Long
    For itm = 1 To UBound(UniqueValues)
        UniqueValues(itm, 3) = WorksheetFunction.CountIfs(Target.Columns(1), UniqueValues(itm, 1), Target.Columns(2), UniqueValues(itm, 2))
    Next itm
    
    Dim wsOutRange As Range
    Set wsOutRange = wsOut.Cells(lastRowOut, 2).Resize(UBound(UniqueValues), 3)
    
    wsOutRange = UniqueValues
    With wsOut.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsOutRange.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=wsOutRange.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range(wsOutRange.Address)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With

End Sub