Home > Net >  VBA: Count times a pair of values appears
VBA: Count times a pair of values appears

Time:07-01

To generate from this:

enter image description here

that:

enter image description here

I have this piece of code:

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

I tried to implement a code to generate in addition this output marked in red:

enter image description here

So what I'm trying is to count and list every pair that occures. I tried to implement "countifs" into the if-statement but it failed. The actual table has over 40 entries in "City" and over 10 entries in "Departement" and over 6.000 entries in total. Would be happy if someone can help me out with this. Thanks in advance guys!

CodePudding user response:

No VBA required.

Formula in E2 is =SORT(UNIQUE($B$2:$C$18),{1,2},{1,1})
Formula in G2 is =COUNTIFS($B$2:$B$18,INDEX(E2#,,1),$C$2:$C$18,INDEX(E2#,,2))

enter image description here

VBA Solution:
Result in the test procedure will hold your values, or can be used on a worksheet as =SORT(CountCities(B2:C18),{1,2},{1,1}) to get same result as my first solution.

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

Everything in one procedure:

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

CodePudding user response:

As you mention in your comment, you seem not to know how to record a macro: you go to the "Developer" ribbon (you might need to enable it first) and in the first part, you click "Record macro" and you just start doing what you want to record (in this case, insert a pivot table).

I've just done that, using a range "A1:B8" as input and creating the kind of pivot table you are looking for, and the following code gets created automatically (beware that this is automatically added code, which has a lot of superfluous lines, parameters, ...: it's ok to use it as a starting point but it's very useful trying to learn from it by modifying, deleting, ... parts of it):

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

By the way: as you can see from the name "PivotTable3", I did not succeed from my first attempt :-)

CodePudding user response:

Count Column Pairs (Dictionary)

  • Adjust (play with) the values in the constants section.
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
  • Related