To generate from this:
that:
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:
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))
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