Pull distinct number from independant columns

[Legacy 505880]

Hello everybody. These days I've been trying to find a function that can pull a number from each column in a selected range so that all pulled numbers are different.
For example, if the Starting columns are A:[1,3,5], B[1,2,3], C[4,6], D[1], a possible solution could be [3,2,6,1], or [5,2,4,1]. Note that there are dependancies between columns: for example, 1 can't be pulled from column A because there would be no numbers to pull in D. So far the best answer i could get is to pull numbers randomly until you get a valid solution. I was wondering if there was a way to not use this recursive method, but a more deterministic approach, to always get distinct numbers (if not impossible).

 

[Legacy 143009]

How about this? A bit heuristic but dıes the job

Sub test()
  Dim myRange As Variant, resultArr As Variant, rndRow As Long, exist As Boolean, counter As Long
  myRange = Intersect(UsedRange, Range("A:D"))
  ReDim resultArr(1 To UBound(myRange, 2), 1 To 1)
  
  For i = 1 To UBound(myRange, 2)
    Do
      rndRow = (Timer * Rnd) Mod (UBound(myRange, 1) - 1 + 1) + 1
      exist = False
      For j = 1 To UBound(resultArr, 1)
        If myRange(rndRow, i) = resultArr(j, 1) Then
          exist = True
        End If
      Next
      counter = counter + 1
      If (counter + 1) Mod UBound(myRange, 2) = 0 Then
        i = 1
      End If
    Loop While exist = True Or IsEmpty(myRange(rndRow, i))
    resultArr(i, 1) = myRange(rndRow, i)
  Next
  Range("E1").Resize(UBound(resultArr)) = resultArr
End Sub

 

[Legacy 143009]

change this line

If (counter + 1) Mod UBound(myRange, 2) = 0 Then

to this:

If counter Mod UBound(myRange, 2) = 0 Then

 

[Legacy 143009]

Modify the same line like this:

If counter Mod (UBound(myRange, 2) * 3) = 0 Then

 

[Legacy 505880]

Can you briefly tell me how this works? Also i realised that my explanation was unclear: i already have an udf that loops until a soulution is found:

Option Explicit

Private dict As Object
Private solve As Integer
Private inp_col(), inp_arr()

Function Get_Rnd_Row(inp As Range) As String
    
    'Keep below line if you want to make the function volatile, else comment it out
    Application.Volatile
    
    Dim i As Integer, j As Integer, x As Integer, y As Integer, cl As Integer, rw As Integer
    Dim answer As String, rnd_arr(), Key, temp

    ' Get number of columns and rows in input range
    cl = inp.Columns.Count
    rw = inp.Rows.Count
    
    ' Redim arrays as per input range size
    ReDim inp_arr(1 To rw, 1 To cl)
    ReDim inp_col(1 To cl)
    ReDim rnd_arr(1 To rw)
    
    ' Initialize inp_arr to mirror the input range
    inp_arr = inp
    
    ' Initialize inp_col to indicate number of values in each column based on count
    ' The values in each column should be numbers to be identified by Excel COUNT function
    For i = 1 To cl
        inp_col(i) = WorksheetFunction.Count(inp.Cells(1, 1).Resize(rw).Offset(0, i - 1))
    Next i
    
    'Randomly sort all columns in inp_arr
    For i = 1 To cl
        For j = 1 To inp_col(i)
            rnd_arr(j) = Rnd
        Next j
        
        For x = 1 To inp_col(i) - 1
            For y = x + 1 To inp_col(i)
                If rnd_arr(x) > rnd_arr(y) Then
                    temp = rnd_arr(x)
                    rnd_arr(x) = rnd_arr(y)
                    rnd_arr(y) = temp
                    
                    temp = inp_arr(x, i)
                    inp_arr(x, i) = inp_arr(y, i)
                    inp_arr(y, i) = temp
                End If
            Next y
        Next x
    Next i
    
    ' Initialize dictionary object and set solve to 0
    Set dict = CreateObject("Scripting.Dictionary")
    solve = 0
    
    ' Call the recursive procedure to find solution
    Call find_random_row(1, cl)
    
    If solve = 0 Then
        Get_Rnd_Row = "None found"
    Else
        answer = ""
    
        For Each Key In dict.Keys
            If answer = "" Then
                answer = Key
            Else
                answer = answer & "|" & Key
            End If
        Next Key
        
        Get_Rnd_Row = answer
    End If

End Function

Sub find_random_row(c_num As Integer, c_max As Integer)
    Dim i As Integer
    
    'Loop through all values till a solution is found
    For i = 1 To inp_col(c_num)
        'Check if the value in that row in c_num column has not been considered from another column earlier
        'If not already considered, add it to the dictionary
        If Not dict.Exists(inp_arr(i, c_num)) Then
            dict.Add inp_arr(i, c_num), c_num
            
            'Move to next column to find another value, or exit if all columns have been looped through and assigned a value
            If c_num = c_max Then
                solve = 1
            Else
                Call find_random_row(c_num + 1, c_max)
            End If
            
            'If reaching here with no solution still found, remove the value from dictionary
            'If solution has been found, no need to loop further
            If solve = 0 Then
                dict.Remove inp_arr(i, c_num)
            Else
                Exit For
            End If
        End If
    Next i
End Sub

My question is if there is a way to somehow find the solution in the first try, without looping. Thank you in advance

 

[Legacy 505880]

i just realised that what i'm asking is probably impossible, so the right wording might be "what is the shortest path to find a solution?". Let me know if you have any more ideas

 

[Legacy 143009]

Get a unique result in a random environment on the first try? This will be interesting,
Besides this mission impossible, using dictionaries is clever. Here is my last version:

Sub test()
  Dim myRange As Variant, resultArr As Object, rndRow As Long, results As Variant
  myRange = Intersect(UsedRange, Range("A:D"))
  Set resultArr = CreateObject("Scripting.dictionary")
  For i = 1 To UBound(myRange, 2)
    Do
      rndRow = (Timer * Rnd) Mod (UBound(myRange, 1) - 1 + 1) + 1
      For j = 1 To UBound(myRange, 1)
        If Not resultArr.exists(myRange(rndRow, i)) And Not IsEmpty(myRange(rndRow, i)) Then
          resultArr.Add myRange(rndRow, i), 1
          Exit Do
        Else
          counter = counter + 1
          If counter Mod UBound(myRange, 2) = 0 Then
             i = 1
             resultArr.RemoveAll
          End If
        End If
      Next
    Loop
  Next
  results = Array(resultArr.keys, resultArr.items)
  Range("E1").Resize(resultArr.Count) = Application.Transpose(results)
End Sub

 

[Legacy 143009]

Ok, I think this is the fastest way. I can't think of a faster way. Or you must wait for other answers.

Sub test()
  Dim myRange As Variant, resultArr As Object, rndRow As Long, results As Variant, counter As Long
  myRange = Intersect(UsedRange, Range("AD"))
  Set resultArr = CreateObject("Scripting.dictionary")

  For i = 1 To UBound(myRange, 2)
  counter = 0
    Do
      rndRow = (Timer * Rnd) Mod (UBound(myRange, 1) - 1 + 1) + 1
      If Not resultArr.exists(myRange(rndRow, i)) And Not IsEmpty(myRange(rndRow, i)) Then
        resultArr.Add myRange(rndRow, i), 1
        Exit Do
      Else
        counter = counter + 1
        If counter = UBound(myRange, 1) Then
          resultArr.RemoveAll
          i = 1
        End If
      End If
    Loop
  Next

  results = Array(resultArr.keys, resultArr.items)
  Range("E1").Resize(resultArr.Count) = Application.Transpose(results)
End Sub

 

[Legacy 505880]

Thanks man, i really appreciate this

 

[Legacy 505880]

Ok, I think this is the fastest way. I can't think of a faster way. Or you must wait for other answers.

Sub test()
  Dim myRange As Variant, resultArr As Object, rndRow As Long, results As Variant, counter As Long
  myRange = Intersect(UsedRange, Range("AD"))
  Set resultArr = CreateObject("Scripting.dictionary")

  For i = 1 To UBound(myRange, 2)
  counter = 0
    Do
      rndRow = (Timer * Rnd) Mod (UBound(myRange, 1) - 1 + 1) + 1
      If Not resultArr.exists(myRange(rndRow, i)) And Not IsEmpty(myRange(rndRow, i)) Then
        resultArr.Add myRange(rndRow, i), 1
        Exit Do
      Else
        counter = counter + 1
        If counter = UBound(myRange, 1) Then
          resultArr.RemoveAll
          i = 1
        End If
      End If
    Loop
  Next

  results = Array(resultArr.keys, resultArr.items)
  Range("E1").Resize(resultArr.Count) = Application.Transpose(results)
End Sub

Could this VBA be faster than yours?
Sub test()
Dim i As Long, ii As Long, s(3) As String
Dim cn As Object, rs As Object, x, n As Long
[j1].CurrentRegion.Offset(1).ClearContents
[j4].CurrentRegion.Offset(1).ClearContents
With [a1].CurrentRegion
For i = 1 To .Columns.Count
.Columns(i).Name = "Col_" & i
s(0) = s(0) & " ,[Col_" & i & "].F1"
s(1) = s(1) & " ,[Col_" & i & "]"
s(2) = s(2) & " And [Col_" & i & "].F1 Is Not Null"
For ii = i + 1 To .Columns.Count
s(3) = s(3) & " And [Col_" & i & "].F1 <> [Col_" & ii & "].F1"
Next
Next
s(0) = Mid$(s(0), 3): s(1) = Mid$(s(1), 3): s(2) = Mid$(s(2), 5)
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 12.0;HDR=No;"""
rs.Open "Select " & s(0) & " From " & s(1) & " Where " & s(2) & s(3) & " Order By " & s(0) & ";", cn, 3, 3, 1
n = rs.RecordCount: x = rs.GetRows
[j5].Resize(n, rs.Fields.Count) = Application.Transpose(x)
n = WorksheetFunction.RandBetween(1, n)
[j2].Resize(, rs.Fields.Count) = Application.Transpose(Application.Index(x, 0, n))
Set cn = Nothing: Set rs = Nothing
For i = 1 To .Columns.Count
.Parent.Parent.Names("Col_" & i).Delete
Next
End With
End Sub