VBA Failing to set a condition within a combination generator loop-CodePudding

The other day someone already helped a great deal with adjusting this code but I have to add a condition now that is not creating the combination, but has to make sure that Column B, D and F only mix when the value in Column A, C and E are matching each other. Let me show you what I mean:

Region 1	Item 1	Region 2	Item 2	Region 3	Item 3
EMEA	ABC	EMEA	123	US	one
US	DEF	US	456	EMEA	two

The end result should therefore be as follows:

ABC-123-two
DEF-456-one

I tried to set something up in the current code but failed and removed it from the code. Ideally what needs to happen is that it first ignores any empty value in the range and then checks if the region is equal to the region in the second item or third item.

Here is the VBA, any advice would be very much appreciated. Thanks in advance:

Sub CombinationGenerator()

Dim xDRg1 As Range, xDRg2 As Range, xDRg3 As Range
Dim xRg  As Range
Dim xStr As String
Dim xFN1 As Range, xFN2 As Range, xFN3 As Range
Dim xSV1 As String, xSV2 As String, xSV3 As String

Set xDRg1 = Range("B2:B75")  'First column combintation data
Set xDRg2 = Range("D2:D75")  'Second column combintation data
Set xDRg3 = Range("F2:F75")  'Third column combintation data
xStr = "-"   'Separator
Set xRg = Range("I2")  'Output cell

'Creating combinations
For Each xFN1 In xDRg1.Cells
If xFN1 <> "" Then 'Ignore empty cells
    xSV1 = xFN1.Text

    For Each xFN2 In xDRg2.Cells
        If xFN2 <> "" Then 'Ignore empty cells
        xSV2 = xFN2.Text

      For Each xFN3 In xDRg3.Cells
        If xFN3 <> "" Then 'Ignore empty cells
        xSV3 = xFN3.Text
        
        xRg.Value = xSV1 & xStr & xSV2 & xStr & xSV3
        Set xRg = xRg.Offset(1, 0)
            End If
       Next
       End If
    Next
End If
Next
End Sub

CodePudding user response：

Sub combo()

    Dim ar, n As Long, x As Long, y As Long
    Dim z As Long, r As Long
    Dim t0 As Single: t0 = Timer
    ar = Sheet1.UsedRange.Value2
    n = UBound(ar)
    r = 1
    
    For x = 2 To n
        If Len(ar(x, 1)) > 0 Then
            For y = 2 To n
                If ar(x, 1) = ar(y, 3) Then
                    For z = 2 To n
                        If ar(x, 1) = ar(z, 3) Then
                             r = r   1
                             Sheet2.Cells(r, "I").Value2 = ar(x, 2) & "-" & ar(y, 4) & "-" & ar(z, 6)
                        End If
                    Next
                End If
            Next
        End If
    Next
    MsgBox r - 1 & " lines", vbInformation, Format(Timer - t0, "0.0 secs")

CodePudding user response：

Given your data has related information conflated together namely in region and item pairings, consider an SQL solution. No loops needed and can scale efficiently. You can run SQL directly on tabular structured worksheets in Excel VBA if you use Excel for Windows (not Mac) to connect to the Access engine.

Below SQL runs self join on same worksheet breaking up the pairings as their own table related by region. (Parentheses are required.)

SELECT s1.[Region 1]
     , s1.[Item 1]
     , s2.[Item 2]
     , s3.[Item 3]
FROM (([Sheet1$] s1
LEFT JOIN [Sheet1$] s2
   ON s1.[Region 1] = s2.[Region 2])
LEFT JOIN [Sheet1$] s3
   ON s1.[Region 1] = s3.[Region 3])

To run above query via ODBC connection to workbook, see my numerous past VBA answers:

Additionally, without VBA, if you have MS Access installed you can link your Excel worksheet and run same SQL swapping out [Sheet1$]. Alternatively, in Accces run query directly on external workbook:

SELECT s1.[Region 1]
     , s1.[Item 1]
     , s2.[Item 2]
     , s3.[Item 3]
FROM (([Excel 12.0 Xml;HDR=Yes;Database=C:\Path\To\Workbook.xlsx].[Sheet1$] AS s1
LEFT JOIN [Excel 12.0 Xml;HDR=Yes;Database=C:\Path\To\Workbook.xlsx].[Sheet1$] s2
   ON s1.[Region 1] = s2.[Region 2])
LEFT JOIN [Excel 12.0 Xml;HDR=Yes;Database=C:\Path\To\Workbook.xlsx].[Sheet1$] s3
   ON s1.[Region 1] = s3.[Region 3])