VBA: Combining 4 colums into combinations, but skip double values

S

Styx

New Member
Joined
Nov 19, 2021
Messages
20
Office Version
  1. 2007
Platform
  1. Windows
I need help with a combination generator.
I found some good startpoints here, but the result is too long, I need an extra filter.
In my (borrowed) example there are 4 colums of which 2 pairs are identical. (most of the times)
The combination I am looking for must skip the combination where the value from column A is identical to the value in column C, and also where the value from column B is identical to the value in column D.
In other words: result must be completely unique.
this is what I have:

VBA Code: 
Sub 4-column-combi()

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

Columns("F:F").Select
    Selection.ClearContents
    Range("F1").Select

Set xDRg1 = Range("A1:A15")  'First column data
Set xDRg2 = Range("B1:B8")  'Second column data
Set xDRg3 = Range("C1:C15")  'Third column data
Set xDRg4 = Range("D1:D8")  'Third column data
xStr = "-"   'Separator
Set xRg = Range("F1")  'Output cell
 For xFN1 = 1 To xDRg1.Count
     xSV1 = xDRg1.Item(xFN1).Text
    
    For xFN2 = 1 To xDRg2.Count
        xSV2 = xDRg2.Item(xFN2).Text
      
      For xFN3 = 1 To xDRg3.Count
        xSV3 = xDRg3.Item(xFN3).Text
        
        For xFN4 = 1 To xDRg4.Count
          xSV4 = xDRg4.Item(xFN4).Text
        
        xRg.Value = xSV1 & xStr & xSV2 & xStr & xSV3 & xStr & xSV4
        
        Set xRg = xRg.Offset(1, 0)
       Next
     Next
  Next
Next
End Sub

result =
LB1.xlsm
ABCDEF
1101201101201101-201-101-201
2102202102202101-201-101-202
3103203103203101-201-101-203
4104204104204101-201-101-204
5105205105205101-201-101-205
6106206106206101-201-101-206
7107207107207101-201-101-207
8108208108208101-201-101-208
9109109101-201-102-201
10110110101-201-102-202
11111111101-201-102-203
12112112101-201-102-204
13113113101-201-102-205
14114114101-201-102-206
15115115101-201-102-207
16101-201-102-208
17101-201-103-201
18101-201-103-202
Blad1


(the result in F is way longer than in my screenshot)
You can already see that 1st result = 101-201-101-102 but this is invalid because there are double values in the result.
The first correct value from this list is the 10th one: 101-201-102-202
And it would be superb if result is also in 4 columns. e.g.: column F, G, H, I filled with the seperate values.
Of course column A, B, C and D are dynamic, so tomorrow list A and C are maybe 4 rows long and column B and D 12 rows.
and sometimes all 4 columns are the same. so then the first result correct could be 101-102-103-104.
And if I have a working result, then I like to have some tweaking parameters implemented, but above question is the most important, lets start with that.

Thanks in advance!
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
Try this:

VBA Code: 
Sub Combining4colums()
  Dim a As Variant, b As Variant, c As Variant, d As Variant, f As Variant
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
  Dim dic As Object
  
  a = Range("A1", Range("A" & Rows.Count).End(3)).Value
  b = Range("B1", Range("B" & Rows.Count).End(3)).Value
  c = Range("C1", Range("C" & Rows.Count).End(3)).Value
  d = Range("D1", Range("D" & Rows.Count).End(3)).Value
  ReDim f(1 To UBound(a) * UBound(b) * UBound(c) * UBound(d), 1 To 4)
  Set dic = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    dic(a(i, 1)) = Empty
    For j = 1 To UBound(b)
      If Not dic.exists(b(j, 1)) Then
        dic(b(j, 1)) = Empty
        For k = 1 To UBound(c)
          If Not dic.exists(c(k, 1)) Then
            dic(c(k, 1)) = Empty
            For m = 1 To UBound(d)
              If Not dic.exists(d(m, 1)) Then
                n = n + 1
                f(n, 1) = a(i, 1)
                f(n, 2) = b(j, 1)
                f(n, 3) = c(k, 1)
                f(n, 4) = d(m, 1)
              End If
            Next m
            dic.Remove c(k, 1)
          End If
        Next k
        dic.Remove b(j, 1)
      End If
    Next j
    dic.Remove a(i, 1)
  Next
  Range("F1").Resize(n, 4) = f
End Sub
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
Sub Combining4colums()
  Dim a As Variant, b As Variant, c As Variant, d As Variant, f As Variant
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
  Dim dic As Object
 
  a = Range("A1", Range("A" & Rows.Count).End(3)).Value
  b = Range("B1", Range("B" & Rows.Count).End(3)).Value
  c = Range("C1", Range("C" & Rows.Count).End(3)).Value
  d = Range("D1", Range("D" & Rows.Count).End(3)).Value
  ReDim f(1 To UBound(a) * UBound(b) * UBound(c) * UBound(d), 1 To 4)
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    dic(a(i, 1)) = Empty
    For j = 1 To UBound(b)
      If Not dic.exists(b(j, 1)) Then
        dic(b(j, 1)) = Empty
        For k = 1 To UBound(c)
          If Not dic.exists(c(k, 1)) Then
            dic(c(k, 1)) = Empty
            For m = 1 To UBound(d)
              If Not dic.exists(d(m, 1)) Then
                n = n + 1
                f(n, 1) = a(i, 1)
                f(n, 2) = b(j, 1)
                f(n, 3) = c(k, 1)
                f(n, 4) = d(m, 1)
              End If
            Next m
            dic.Remove c(k, 1)
          End If
        Next k
        dic.Remove b(j, 1)
      End If
    Next j
    dic.Remove a(i, 1)
  Next
  Range("F1").Resize(n, 4) = f
End Sub
Click to expand...
Hi DanteAmor,

It is perfect! Thanks a lot!
Now I need the following parameter implemented if possible.
If sum of left 2 digits from ABS(F1+G1) - ABS(H1+I1) > E2 then result is not valid, where E2 is a manual variable.
e.g. 1st result in first row is now 101, 102, 103, 104
If for example E2 has a value of 2
Sum to be used: ABS(01+02) - ABS(03+04) , result is 3-7=ABS(-4) = 4
4 is higher than value in E2 so it is an invalid result.
Hopefully it is possible to implement.
Thanks in advance!
 
Upvote 0
Styx said:
Hi DanteAmor,

It is perfect! Thanks a lot!
Now I need the following parameter implemented if possible.
If sum of left 2 digits from ABS(F1+G1) - ABS(H1+I1) > E2 then result is not valid, where E2 is a manual variable.
e.g. 1st result in first row is now 101, 102, 103, 104
If for example E2 has a value of 2
Sum to be used: ABS(01+02) - ABS(03+04) , result is 3-7=ABS(-4) = 4
4 is higher than value in E2 so it is an invalid result.
Hopefully it is possible to implement.
Thanks in advance!
Click to expand...
I made an error in my request:
If sum of left 2 digits from ABS(F1+G1) - ABS(H1+I1) > E2 then result is not valid, where E2 is a manual variable.
should be
If sum of right 2 digits from ABS(F1+G1) - ABS(H1+I1) > E2 then result is not valid, where E2 is a manual variable.
 
Upvote 0
VBA Code: 
Sub test()
Lra = Cells(65000, "A").End(xlUp).Row
Lrb = Cells(65000, "B").End(xlUp).Row
Lrc = Cells(65000, "C").End(xlUp).Row
Lrd = Cells(65000, "D").End(xlUp).Row
For a = 1 To Lra
    For b = 1 To Lrb
        For c = 1 To Lrc
            For d = 1 To Lrd
            If Cells(a, "A") <> Cells(b, "B") And Cells(a, "A") <> Cells(c, "C") _
                And Cells(a, "A") <> Cells(d, "D") And Cells(b, "B") <> Cells(c, "C") _
                And Cells(b, "B") <> Cells(d, "D") And Cells(c, "C") <> Cells(d, "D") _
                And (Abs(Right(Cells(a, "A"), 2) * 1 + Right(Cells(b, "B"), 2) * 1 - _
                Right(Cells(c, "C"), 2) * 1 - Right(Cells(d, "D"), 2)) * 1 <= Cells(2, "E")) Then
            k = k + 1
                Cells(k, "F").Value = Cells(a, "A").Value
                Cells(k, "G").Value = Cells(b, "B").Value
                Cells(k, "H").Value = Cells(c, "C").Value
                Cells(k, "I").Value = Cells(d, "D").Value
            End If
            Next
        Next
    Next
Next
End Sub
 
Upvote 0
Also perfect! Thanks bebo021999 !! Just changing the E factor to the fixed cell E1 was enough.
But the next step is to filter also combinations which also aready exist but in a different combination.
There are double combinations but in different columns.
The FG combination with the HI combination may only exist once.
So if there is another combination where the FG combination (in any order) with HI combination (in any order) is the "same" with the FG and HI combination then these must be skipped, so only the unique FG and HI combination may remain.
I highlighted 2 rows with same combination but in different order, there are more in this short list. (e.g. row 2 and 7 are also the "same".)
In this example I like to keep the 1st unique combination in row 1 and skip row 6.

Test-Macro_c0.02.xlsm
ABCDEFGHIJ
11012011012010101202102201<--
2102202102202101203102202
3103203103203101203103201
4204204101204102203
5101204103202
6102201101202<--
7102202101203
8102202103201
9102203101204
10102203103202
11102204103203
12103201101203
13103201102202
14103202101204
15103202102203
16103203102204
Blad1
 
Upvote 0
VBA Code: 
Sub test()
Lra = Cells(Rows.Count, "A").End(xlUp).Row
Lrb = Cells(Rows.Count, "B").End(xlUp).Row
Lrc = Cells(Rows.Count, "C").End(xlUp).Row
Lrd = Cells(Rows.Count, "D").End(xlUp).Row
k = 1
For Each rngA In Range("A1:A" & Lra)
    For Each rngB In Range("B1:B" & Lrb)
        For Each rngC In Range("C1:C" & Lrc)
            For Each rngD In Range("D1:D" & Lrd)
            With WorksheetFunction
            If rngA <> rngB And rngA <> rngC And rngA <> rngD And rngB <> rngC And rngB <> rngD And rngC <> rngD _
                And Abs(Right(rngA, 2) * 1 + Right(rngB, 2) * 1 - Right(rngC, 2) * 1 - Right(rngD, 2) * 1) <= Cells(1, "E") Then
                k = k + 1
                If .CountIfs(Range("F1:F" & k - 1), rngC, Range("G1:G" & k - 1), rngD, Range("H1:H" & k - 1), rngA, Range("I1:I" & k - 1), rngB) = 0 Then
                    Cells(k, "F").Value = rngA
                    Cells(k, "G").Value = rngB
                    Cells(k, "H").Value = rngC
                    Cells(k, "I").Value = rngD
                Else
                k = k - 1
                End If
            End If
            End With
            Next
        Next
    Next
Next
End Sub
 
Upvote 0
Hi bebo021999 and DanteAmor both solutions were perfect, where bobo021999 added some extra tweaks which I requested later on.
This thread may be closed, but I start another one which needs some tweaking on the latest result, but then I also explain where it is for. (I think that will be the hardest part)
Thanks for your help and hopefully you are also able to help with the next thread which will be called:
VBA: Filter correct matches/games from player matchlist.
This may be a new seperate macro.
Thanks for the help !!!
 
Upvote 0
Styx said:
should be
If sum of right 2 digits from ABS(F1+G1) - ABS(H1+I1) > E2 then result is not valid, where E2 is a manual variable.
Click to expand...
Try this:

VBA Code: 
Sub Combining4colums()
  Dim a As Variant, b As Variant, c As Variant, d As Variant, f As Variant
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
  Dim dic As Object
  Dim vx As Variant
  
  a = Range("A1", Range("A" & Rows.Count).End(3)).Value
  b = Range("B1", Range("B" & Rows.Count).End(3)).Value
  c = Range("C1", Range("C" & Rows.Count).End(3)).Value
  d = Range("D1", Range("D" & Rows.Count).End(3)).Value
  ReDim f(1 To UBound(a) * UBound(b) * UBound(c) * UBound(d), 1 To 4)
  Set dic = CreateObject("Scripting.Dictionary")
  vx = Range("E1").Value
  
  For i = 1 To UBound(a)
    dic(a(i, 1)) = Empty
    For j = 1 To UBound(b)
      If Not dic.exists(b(j, 1)) Then
        dic(b(j, 1)) = Empty
        For k = 1 To UBound(c)
          If Not dic.exists(c(k, 1)) Then
            dic(c(k, 1)) = Empty
            For m = 1 To UBound(d)
              If Not dic.exists(d(m, 1)) Then
                If Abs(Right(a(i, 1), 2) + Right(b(j, 1), 2) - _
                       Right(c(k, 1), 2) - Right(d(m, 1), 2)) <= vx Then
                  n = n + 1
                  f(n, 1) = a(i, 1)
                  f(n, 2) = b(j, 1)
                  f(n, 3) = c(k, 1)
                  f(n, 4) = d(m, 1)
                End If
              End If
            Next m
            dic.Remove c(k, 1)
          End If
        Next k
        dic.Remove b(j, 1)
      End If
    Next j
    dic.Remove a(i, 1)
  Next
  If n > 0 Then Range("F1").Resize(n, 4) = f
End Sub
 
Upvote 0
Hi DanteAmor,
This gives me an empty list. I think I have to playe around with <=vx I think
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
I want to do a combination in the scope excluding empty cells in the VBA Range area.
Replies
3
Views
471
ted kim
T
M
  • Question Question
VBA Code error - Range
Replies
8
Views
3K
Joe4
Joe4
G
  • Solved
Split items into Rows
Replies
2
Views
525
GreyFox8991
G
R
  • Solved
VBA code to create a 3 column import template from table with 100 columns
Replies
6
Views
533
rjheibel
R
A
  • Question Question
Data Selection Based on Closest Value [20% Tolerance]
Replies
1
Views
206
StephenCrump
S

Forum statistics

Threads
1,223,964
Messages
6,175,659
Members
452,666
Latest member
AllexDee

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top