Trying to find missing pairs with macro or a manual process

[sncb]

I have a situation where I have a list of 17 cities and every item code needs to exist in exactly those 17 cities. The issue I have is my items do not exist in all the cities but in only some of them and I need a macro to identify only those cities (with the item code beside them) where the correction would need to be done. I dont know if a macro would be the best solution or another way to extract these but since I have to do these checks very regularly, I think a macro would be the way to go but any suggestions are welcome.

The number of records (rows) change each time based on the data Im trying to correct. Thanks in advance if anyone could advise or help with a macro code.

No headers
Col A are all the cities
Cols C&D is what my existing data looks like
Cols F&G is what I am trying to extract.

 

[Legacy 143009]

Glad it did work. Thanks for the feedback

 

[Alex Blakenburg]

I know you already have a solution but I may as well post it anyway.

This is uses a dictionary so it might be a bit faster.

Sub CompleteCityCombinations()

    Dim shtData As Worksheet
    Dim cityRng As Range, srcRng As Range, outRng As Range
    Dim cityArr As Variant, srcArr As Variant, outArr As Variant
    Dim srcDic As Object, ItemDic As Object
    Dim ItemKey As String, srcKey As String
    Dim iKey As Variant
    Dim i As Long, iOut As Long
    
    Set shtData = ActiveSheet
    With shtData
        Set cityRng = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        Set srcRng = .Range("C1:D" & .Cells(Rows.Count, "C").End(xlUp).Row)
        Set outRng = .Range("F1")
        cityArr = cityRng
        srcArr = srcRng
    End With
    
    
    Set ItemDic = CreateObject("Scripting.dictionary")
    Set srcDic = CreateObject("Scripting.dictionary")
    
    ' Load details range into Dictionary & get unique items list
    For i = 1 To UBound(srcArr)
        srcKey = srcArr(i, 1) & "|" & srcArr(i, 2)
        ItemKey = srcArr(i, 2)
        If Not srcDic.exists(srcKey) Then
            srcDic(srcKey) = i
        End If
        
        If Not ItemDic.exists(ItemKey) Then
            ItemDic(ItemKey) = i
        End If
    Next i
    
    ' Loop through unique items and check for every city-item combination
    ' if it doesn't exist put it in the output array
    ReDim outArr(1 To UBound(cityArr) * ItemDic.Count, 1 To 2)
    For Each iKey In ItemDic.Keys
        For i = 1 To UBound(cityArr)
            srcKey = cityArr(i, 1) & "|" & iKey
            If Not srcDic.exists(srcKey) Then
                iOut = iOut + 1
                outArr(iOut, 1) = cityArr(i, 1)
                outArr(iOut, 2) = iKey
            End If
        Next i
    
    Next iKey
    
    outRng.Resize(iOut, UBound(outArr, 2)) = outArr

End Sub

 

[sncb]

I know you already have a solution but I may as well post it anyway.

This is uses a dictionary so it might be a bit faster.

Sub CompleteCityCombinations()

    Dim shtData As Worksheet
    Dim cityRng As Range, srcRng As Range, outRng As Range
    Dim cityArr As Variant, srcArr As Variant, outArr As Variant
    Dim srcDic As Object, ItemDic As Object
    Dim ItemKey As String, srcKey As String
    Dim iKey As Variant
    Dim i As Long, iOut As Long
   
    Set shtData = ActiveSheet
    With shtData
        Set cityRng = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        Set srcRng = .Range("C1:D" & .Cells(Rows.Count, "C").End(xlUp).Row)
        Set outRng = .Range("F1")
        cityArr = cityRng
        srcArr = srcRng
    End With
   
   
    Set ItemDic = CreateObject("Scripting.dictionary")
    Set srcDic = CreateObject("Scripting.dictionary")
   
    ' Load details range into Dictionary & get unique items list
    For i = 1 To UBound(srcArr)
        srcKey = srcArr(i, 1) & "|" & srcArr(i, 2)
        ItemKey = srcArr(i, 2)
        If Not srcDic.exists(srcKey) Then
            srcDic(srcKey) = i
        End If
       
        If Not ItemDic.exists(ItemKey) Then
            ItemDic(ItemKey) = i
        End If
    Next i
   
    ' Loop through unique items and check for every city-item combination
    ' if it doesn't exist put it in the output array
    ReDim outArr(1 To UBound(cityArr) * ItemDic.Count, 1 To 2)
    For Each iKey In ItemDic.Keys
        For i = 1 To UBound(cityArr)
            srcKey = cityArr(i, 1) & "|" & iKey
            If Not srcDic.exists(srcKey) Then
                iOut = iOut + 1
                outArr(iOut, 1) = cityArr(i, 1)
                outArr(iOut, 2) = iKey
            End If
        Next i
   
    Next iKey
   
    outRng.Resize(iOut, UBound(outArr, 2)) = outArr

End Sub

Thanks to you as well. This worked like a charm too.

 

[Alex Blakenburg]

Thank you for taking the time to test it and provide feedback.

 

[Mario_R]

... The number of records (rows) change each time based on the data Im trying to correct. Thanks in advance if anyone could advise or help with a macro code.

@sncb:
I ask you -only- out of curiosity: Did you observe what was suggested in post #8?...

 

[Alex Blakenburg]

@sncb:
I ask you -only- out of curiosity: Did you observe what was suggested in post #8?...

You seem to have read the requirements differently.
• Our understanding is that we needed to keep the original list intact and produce a list of the missing city-item combination. Your code is creating all combinations and overwriting the original list.
• Your code is placing a temporary value of "F1" in cell D1, this ignores the statement that there are No headers.
If the first item only had one city in it, the code would not have picked up that item when it created a unique list of items.

Always happy to have another contributor on board.