Pull distinct number from independant columns

NightCa

New Member
Joined
Apr 24, 2023
Messages
18
Office Version
  1. 2021
Platform
  1. Windows
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).
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
How about this? A bit heuristic but dıes the job :)
VBA Code:
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
 
Upvote 0
change this line
VBA Code:
If (counter + 1) Mod UBound(myRange, 2) = 0 Then
to this:
VBA Code:
If counter Mod UBound(myRange, 2) = 0 Then
 
Upvote 0
Modify the same line like this:
VBA Code:
If counter Mod (UBound(myRange, 2) * 3) = 0 Then
 
Upvote 0
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:
VBA Code:
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
 
Upvote 0
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
 
Upvote 0
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:
VBA Code:
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
 
Last edited by a moderator:
Upvote 0
Ok, I think this is the fastest way. I can't think of a faster way. Or you must wait for other answers.
VBA Code:
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
 
Upvote 0
Ok, I think this is the fastest way. I can't think of a faster way. Or you must wait for other answers.
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,246
Messages
6,170,999
Members
452,373
Latest member
TimReeks

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