Sort digits within a cell

T

tiredofit

Well-known Member
Joined
Apr 11, 2013
Messages
1,924
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
I would like to sort the digits in a cell in ascending order.

So for example, I want:

Code: 
6,4,5

to be converted to:

Code: 
4,5,6

I found this code:

Code: 
https://www.mrexcel.com/board/threads/vba-sort-alphanumeric-comma-delimited-text-in-a-cell.1135586/

and I call it as follows:

Code: 
Dim a As Variant

a = SortCSVString(Sheet1.Cells(1, 1).Value2

but it crashes on this line:

Code: 
Sub SortArray(ByRef arr() As String)

    Dim temp As Variant
    Dim i As Long
    Dim j As Long
   
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If CLng(Mid(Trim(arr(i)), 2)) > CLng(Mid(Trim(arr(j)), 2)) Then '***** CRASHES HERE
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
End Sub

with an error message:

Code: 
Run-time error '13':

Type mismatch

I typed this into the Immediate Window:

Code: 
?mid(Trim(arr(i)),2)

and it retuned blank, so I added the CLng and the same error message appeared.

Same error for:

Code: 
?mid(Trim(arr(j)),2)

Can someone point out what's wrong.

Thanks
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
If this is related to your other thread, you can try
VBA Code: 
Sub FindCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change the sheet name if necessary
    
    Dim colA As Range
    Dim colB As Range
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim sum As Long
    Dim results As Collection
    
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set colA = ws.Range("A1:A" & lastRow)
    Set colB = ws.Range("B1:B" & lastRow)
    Set results = New Collection
    
    For i = 1 To lastRow - 1
        For j = i + 1 To lastRow
            sum = colB(i).Value + colB(j).Value
            If sum > 50 Then
                results.Add SortString(colA(i).Value & "," & colA(j).Value)
            Else
                For k = j + 1 To lastRow
                    sum = colB(i).Value + colB(j).Value + colB(k).Value
                    If sum > 50 Then
                        results.Add SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)
                    Else
                        For l = k + 1 To lastRow
                            sum = colB(i).Value + colB(j).Value + colB(k).Value + colB(l).Value
                            If sum > 50 Then
                                results.Add SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)
                            End If
                        Next l
                    End If
                Next k
            End If
        Next j
    Next i
    
    ' Output results
    Dim outputRow As Long
    outputRow = 1
    For Each result In results
        ws.Cells(outputRow, "C").Value = result
        outputRow = outputRow + 1
    Next result
End Sub

Function SortString(inputString As String) As String
    Dim arr() As String
    arr = Split(inputString, ",")
    Dim temp As String
    Dim i As Long, j As Long
    
    ' Bubble sort algorithm
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If Val(arr(i)) > Val(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
    
    SortString = Join(arr, ",")
End Function
 
Upvote 0
Cubist said:
If this is related to your other thread, you can try
VBA Code: 
Sub FindCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change the sheet name if necessary
  
    Dim colA As Range
    Dim colB As Range
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim sum As Long
    Dim results As Collection
  
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set colA = ws.Range("A1:A" & lastRow)
    Set colB = ws.Range("B1:B" & lastRow)
    Set results = New Collection
  
    For i = 1 To lastRow - 1
        For j = i + 1 To lastRow
            sum = colB(i).Value + colB(j).Value
            If sum > 50 Then
                results.Add SortString(colA(i).Value & "," & colA(j).Value)
            Else
                For k = j + 1 To lastRow
                    sum = colB(i).Value + colB(j).Value + colB(k).Value
                    If sum > 50 Then
                        results.Add SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)
                    Else
                        For l = k + 1 To lastRow
                            sum = colB(i).Value + colB(j).Value + colB(k).Value + colB(l).Value
                            If sum > 50 Then
                                results.Add SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)
                            End If
                        Next l
                    End If
                Next k
            End If
        Next j
    Next i
  
    ' Output results
    Dim outputRow As Long
    outputRow = 1
    For Each result In results
        ws.Cells(outputRow, "C").Value = result
        outputRow = outputRow + 1
    Next result
End Sub

Function SortString(inputString As String) As String
    Dim arr() As String
    arr = Split(inputString, ",")
    Dim temp As String
    Dim i As Long, j As Long
  
    ' Bubble sort algorithm
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If Val(arr(i)) > Val(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
  
    SortString = Join(arr, ",")
End Function
Click to expand...
Indeed it is related to the other thread.

I'll try this code of yours tomorrow but re your code on the other thread, there were two situations which didn't work expected:

Situation 1.



1​
100​
2​
3​
4​
5​
6​
7​
8​
9​
10​

Running your code on the above set of data (containing only a single point) returned no results in column C.

Situation 2:



1​
60​
2​
40​
3​
4​
5​
6​
7​
8​
9​
10​

This returned 1,2 in cell C1, which is incorrect.

It should have returned 1 in cell C1 (because the first value, 60 already meets the threshold).

Nevertheless, these were simple fixes and this is how I amended your code:

Code: 
Select Case lastrow
   
        Case 1
               
            Sheet1.Cells(1, 3).Value2 = Sheet1.Cells(1, 1).Value2
           
        Case 2
           
            Select Case Sheet1.Cells(1, 2).Value2
           
                Case Is > Threshold
           
                    Sheet1.Cells(1, 3).Value = Sheet1.Cells(1, 1).Value2
                   
                Case Else
           
                    Sheet1.Cells(1, 3).Value = Sheet1.Cells(1, 1).Value2 & "," & Sheet1.Cells(2, 1).Value2
           
            End Select
       
        Case Else
           
            
            For i = 1 To lastRow - 1
                For j = i + 1 To lastRow
                    sum = colB(i).Value + colB(j).Value
                        If sum > Threshold Then
                            results.Add colA(i).Value & "," & colA(j).Value

etc.

I'll get back tomorrow (it's already past 2am now for me)!
 
Upvote 0
Try this. It should account for all the situations you described.
VBA Code: 
Sub FindCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change the sheet name if necessary
    Dim colA As Range
    Dim colB As Range
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim sum As Long
    Dim results As Object
    Dim threshold As Integer
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set colA = ws.Range("A1:A" & lastRow)
    Set colB = ws.Range("B1:B" & lastRow)
    Set results = CreateObject("Scripting.Dictionary")
    
    threshold = 50
    For i = 1 To lastRow
        If colB(i).Value > threshold Then
            results(SortString(colA(i).Value)) = True
        End If
        For j = i + 1 To lastRow
            If colB(i).Value > threshold Or colB(j).Value > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            End If
            sum = colB(i).Value + colB(j).Value
            If sum > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            Else
                For k = j + 1 To lastRow
                    If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    End If
                    sum = colB(i).Value + colB(j).Value + colB(k).Value
                    If sum > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    Else
                        For l = k + 1 To lastRow
                            If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Or colB(l).Value > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                            sum = colB(i).Value + colB(j).Value + colB(k).Value + colB(l).Value
                            If sum > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                        Next l
                    End If
                Next k
            End If
        Next j
    Next i
    ' Output results
    Dim outputRow As Long
    outputRow = 1
    Dim key As Variant
    For Each key In results.Keys
        ws.Cells(outputRow, "C").Value = key
        outputRow = outputRow + 1
    Next key
End Sub
 
Function SortString(inputString As String) As String
    Dim arr() As String
    arr = Split(inputString, ",")
    Dim temp As String
    Dim i As Long, j As Long
    ' Bubble sort algorithm
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If Val(arr(i)) > Val(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
    SortString = Join(arr, ",")
End Function
 
Upvote 0
Cubist said:
Try this. It should account for all the situations you described.
VBA Code: 
Sub FindCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change the sheet name if necessary
    Dim colA As Range
    Dim colB As Range
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim sum As Long
    Dim results As Object
    Dim threshold As Integer
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set colA = ws.Range("A1:A" & lastRow)
    Set colB = ws.Range("B1:B" & lastRow)
    Set results = CreateObject("Scripting.Dictionary")
 
    threshold = 50
    For i = 1 To lastRow
        If colB(i).Value > threshold Then
            results(SortString(colA(i).Value)) = True
        End If
        For j = i + 1 To lastRow
            If colB(i).Value > threshold Or colB(j).Value > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            End If
            sum = colB(i).Value + colB(j).Value
            If sum > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            Else
                For k = j + 1 To lastRow
                    If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    End If
                    sum = colB(i).Value + colB(j).Value + colB(k).Value
                    If sum > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    Else
                        For l = k + 1 To lastRow
                            If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Or colB(l).Value > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                            sum = colB(i).Value + colB(j).Value + colB(k).Value + colB(l).Value
                            If sum > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                        Next l
                    End If
                Next k
            End If
        Next j
    Next i
    ' Output results
    Dim outputRow As Long
    outputRow = 1
    Dim key As Variant
    For Each key In results.Keys
        ws.Cells(outputRow, "C").Value = key
        outputRow = outputRow + 1
    Next key
End Sub
 
Function SortString(inputString As String) As String
    Dim arr() As String
    arr = Split(inputString, ",")
    Dim temp As String
    Dim i As Long, j As Long
    ' Bubble sort algorithm
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If Val(arr(i)) > Val(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
    SortString = Join(arr, ",")
End Function
Click to expand...
Thanks but it's still not correct 100%.

For example:



1​
60​
2​
40​
3​
4​
5​
6​
7​
8​
9​
10​


returns:

Code: 
1
1,2

but it should just be 1.

Similarly:



1​
55​
2​
20​
3​
5​
4​
5​
5​
5​
6​
5​
7​
5​
8​
9​
10​

returns:



1​
1,2
1,3
1,4
1,5
1,6
1,7

but it should only be 1 because we know the first number (55) already exceeds the threshold (of 50%), so all other cokninations NOT INCLUDING 1 will NOT meet the threshold, so will not be in the results.

I think the code should be this:

Code: 
Sub FindCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change the sheet name if necessary
    Dim colA As Range
    Dim colB As Range
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim sum As Long
    Dim results As Object
    Dim threshold As Integer
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set colA = ws.Range("A1:A" & lastRow)
    Set colB = ws.Range("B1:B" & lastRow)
    Set results = CreateObject("Scripting.Dictionary")
  
    threshold = 50
    For i = 1 To lastRow
        If colB(i).Value > threshold Then
            results(SortString(colA(i).Value)) = True
        Else
        For j = i + 1 To lastRow
            If colB(i).Value > threshold Or colB(j).Value > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            End If
            sum = colB(i).Value + colB(j).Value
            If sum > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True



            Else '***** CHANGED HERE



                For k = j + 1 To lastRow
                    If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    End If
                    sum = colB(i).Value + colB(j).Value + colB(k).Value
                    If sum > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    Else
                        For l = k + 1 To lastRow
                            If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Or colB(l).Value > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                            sum = colB(i).Value + colB(j).Value + colB(k).Value + colB(l).Value
                            If sum > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                        Next l
                    End If
                Next k


            End If '***** CHNAGED HERE


        Next j
        End If
    Next i
    ' Output results
    Dim outputRow As Long
    outputRow = 1
    Dim key As Variant
    For Each key In results.Keys
        ws.Cells(outputRow, "C").Value = key
        outputRow = outputRow + 1
    Next key
End Sub
 
Last edited:
Upvote 0
I do not fully understand what you're trying to accomplish. Perhaps due to the lack of context. I was under the impression that you want all combinations that are minimally over the threshold.
In the example with 60, 40- it's returning 1 and 1,2 because 60 is over 50 (return 1). Go to the next value in col B i.e. 40 (not over 50), add 60 (return 2,1 but sorted to get 1,2).
 
Upvote 0
Cubist said:
I do not fully understand what you're trying to accomplish. Perhaps due to the lack of context. I was under the impression that you want all combinations that are minimally over the threshold.
In the example with 60, 40- it's returning 1 and 1,2 because 60 is over 50 (return 1). Go to the next value in col B i.e. 40 (not over 50), add 60 (return 2,1 but sorted to get 1,2).
Click to expand...
You are correct, that I am seeking all combinations that are minimally over the threshold.

So for this example:

7​
40​
2​
20​
9​
20​
1​
10​
8​
10​
3​
4​
5​
6​
10​

your code IS correctly returning 2,7 - 7,9 - 1,7,8 - 1,2,8,9 because starting with 40, you look at the next number (20) and that gives the combination 7, 2 (which when ordered becomes 2,7).

Since 40,20 meets the threshold, we no longer need to consider any other combinations starting with 40,20, ie since 40,20 meets the threshold, clearly everything that comes afterwards, such as 40,20,20 will also meet the threshold.

In the following example:

1​
60​
2​
40​
3​
4​
5​
6​
7​
8​
9​
10​

since 60 meets the threshold, the only combination required is 1.

Hope my explanation has been consistant.
 
Upvote 0
Try this. In the extreme where there are multiple over the threshold, it'll return all.
Book1
ABC
111001
22802
33553
44504,5
5540
66
77
88
99
1010
Sheet1

VBA Code: 
Sub FindCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1) ' Change the sheet name if necessary
    Dim colA As Range
    Dim colB As Range
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim sum As Long
    Dim results As Object
    Dim threshold As Integer
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set colA = ws.Range("A1:A" & lastRow)
    Set colB = ws.Range("B1:B" & lastRow)
    Set results = CreateObject("Scripting.Dictionary")
   
    threshold = 50
    For i = 1 To lastRow
        If colB(i).Value > threshold Then
            results(SortString(colA(i).Value)) = True
            GoTo overThreshold
        End If
        For j = i + 1 To lastRow
            If colB(i).Value > threshold Or colB(j).Value > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            End If
            sum = colB(i).Value + colB(j).Value
            If sum > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            Else
                For k = j + 1 To lastRow
                    If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    End If
                    sum = colB(i).Value + colB(j).Value + colB(k).Value
                    If sum > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    Else
                        For l = k + 1 To lastRow
                            If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Or colB(l).Value > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                            sum = colB(i).Value + colB(j).Value + colB(k).Value + colB(l).Value
                            If sum > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                        Next l
                    End If
                Next k
            End If
        Next j
overThreshold:
    Next i
    ' Output results
    Dim outputRow As Long
    outputRow = 1
    Dim key As Variant
    For Each key In results.Keys
        ws.Cells(outputRow, "C").Value = key
        outputRow = outputRow + 1
    Next key
End Sub
 
Function SortString(inputString As String) As String
    Dim arr() As String
    arr = Split(inputString, ",")
    Dim temp As String
    Dim i As Long, j As Long
    ' Bubble sort algorithm
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If Val(arr(i)) > Val(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
    SortString = Join(arr, ",")
End Function
 
Upvote 0
Solution
Cubist said:
Try this. In the extreme where there are multiple over the threshold, it'll return all.
Book1
ABC
111001
22802
33553
44504,5
5540
66
77
88
99
1010
Sheet1

VBA Code: 
Sub FindCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1) ' Change the sheet name if necessary
    Dim colA As Range
    Dim colB As Range
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim sum As Long
    Dim results As Object
    Dim threshold As Integer
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set colA = ws.Range("A1:A" & lastRow)
    Set colB = ws.Range("B1:B" & lastRow)
    Set results = CreateObject("Scripting.Dictionary")
 
    threshold = 50
    For i = 1 To lastRow
        If colB(i).Value > threshold Then
            results(SortString(colA(i).Value)) = True
            GoTo overThreshold
        End If
        For j = i + 1 To lastRow
            If colB(i).Value > threshold Or colB(j).Value > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            End If
            sum = colB(i).Value + colB(j).Value
            If sum > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            Else
                For k = j + 1 To lastRow
                    If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    End If
                    sum = colB(i).Value + colB(j).Value + colB(k).Value
                    If sum > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    Else
                        For l = k + 1 To lastRow
                            If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Or colB(l).Value > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                            sum = colB(i).Value + colB(j).Value + colB(k).Value + colB(l).Value
                            If sum > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                        Next l
                    End If
                Next k
            End If
        Next j
overThreshold:
    Next i
    ' Output results
    Dim outputRow As Long
    outputRow = 1
    Dim key As Variant
    For Each key In results.Keys
        ws.Cells(outputRow, "C").Value = key
        outputRow = outputRow + 1
    Next key
End Sub
 
Function SortString(inputString As String) As String
    Dim arr() As String
    arr = Split(inputString, ",")
    Dim temp As String
    Dim i As Long, j As Long
    ' Bubble sort algorithm
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If Val(arr(i)) > Val(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
    SortString = Join(arr, ",")
End Function
Click to expand...
Thanks, I've checked it and it works for all combinations. Nothing more needs to be done or changed.

I have looked at your code but don't understand this line:

Code: 
If colB(i).Value > threshold Or colB(j).Value > threshold Or colB(k).Value > threshold Or colB(l).Value > threshold Then

What I don't understand is why are there FOUR conditions and not, say THREE or FIVE or any other number.
 
Upvote 0
It depends on which index you're on. So if you're on the index for l, it checks all the indexes up to l (i.e. i, j,k, l) so 4. But that brings up a point... I don't believe you need those anymore because your col B is sorted. I originally had it there because col B wasn't sorted so it should work after you remove all those IF statements.
VBA Code: 
Sub FindCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1) ' Change the sheet name if necessary
    Dim colA As Range
    Dim colB As Range
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim sum As Long
    Dim results As Object
    Dim threshold As Integer
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set colA = ws.Range("A1:A" & lastRow)
    Set colB = ws.Range("B1:B" & lastRow)
    Set results = CreateObject("Scripting.Dictionary")
  
    threshold = 50
    For i = 1 To lastRow
        If colB(i).Value > threshold Then
            results(SortString(colA(i).Value)) = True
            GoTo overThreshold
        End If
        For j = i + 1 To lastRow
            sum = colB(i).Value + colB(j).Value
            If sum > threshold Then
                results(SortString(colA(i).Value & "," & colA(j).Value)) = True
            Else
                For k = j + 1 To lastRow
                    sum = colB(i).Value + colB(j).Value + colB(k).Value
                    If sum > threshold Then
                        results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value)) = True
                    Else
                        For l = k + 1 To lastRow
                            sum = colB(i).Value + colB(j).Value + colB(k).Value + colB(l).Value
                            If sum > threshold Then
                                results(SortString(colA(i).Value & "," & colA(j).Value & "," & colA(k).Value & "," & colA(l).Value)) = True
                            End If
                        Next l
                    End If
                Next k
            End If
        Next j
overThreshold:
    Next i
    ' Output results
    Dim outputRow As Long
    outputRow = 1
    Dim key As Variant
    For Each key In results.Keys
        ws.Cells(outputRow, "C").Value = key
        outputRow = outputRow + 1
    Next key
End Sub
 
Function SortString(inputString As String) As String
    Dim arr() As String
    arr = Split(inputString, ",")
    Dim temp As String
    Dim i As Long, j As Long
    ' Bubble sort algorithm
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If Val(arr(i)) > Val(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
    SortString = Join(arr, ",")
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Error message when copying and renaming a worksheet
2
Replies
13
Views
297
smozgur
smozgur
M
  • Question Question
Operational Risk Methodology on VBA
Replies
0
Views
81
Mazurofgod
M
B
  • Locked
  • Question Question
copy range of cells
Replies
1
Views
70
Joe4
Joe4
Z
  • Solved
VBA: Advanced Filter Limitations
Replies
3
Views
615
zero269
Z
K
  • Question Question
I was try to load data To List Box And Transfer data to Sheet2.... (Not work this userform)
Replies
4
Views
191
krunal123
K

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

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