Possible Combination

**kero4000** · 12-24-2018, 12:26 AM

Hello dears

attached work sheet has numbers , each number = some codes

required

when i type in cell F3 number for example "12" , possible combination of codes appears in range H6:H...

as attached i made an example for number "12" possible answers attached in range "H6:H14"

can any one help me with code to make possible combination .

Thanks Possible Combination.xlsx

**大灰狼1976** · 12-24-2018, 07:44 PM

Hi kero4000!
I can't find the law，Can you explain the result after type in 12?

**kero4000** · 12-25-2018, 12:10 AM

Hi 大灰狼1976

thank you very much for your support , you can find number 1,2,3,4,5,6,.....
every number has codes 2= ABC , 3 = DEF , 4 = GHI , ........
i need when i write numbers say 23

then possible combination codes will be :
3 codes * 3 numbers = 9 possibilities

1st possible = AD
2nd Possible = AE
3rd Possible = AF
4th Possible = BD
5th Possible = BE
6th possible = BF
7th Possible = CD
8th possible = CE
9th Possible = CF

is it ok now ?

Thanks

**大灰狼1976** · 12-25-2018, 12:20 AM

But in the example just now，"12" means the combination of "1" and "2".
"1" = .@ and "2"= ABC, so I don't understand, there should be no problem now.
by the way, are there more than two digits?

**大灰狼1976** · 12-25-2018, 12:31 AM

Please refer to the code below. You can use macro or worksheet events.

Sub aaa()
Dim arr, arr1, s$, s1$, s2$, i&, j&, r&
arr = [b5].CurrentRegion
s = [f3]: s1 = arr(Left(s, 1), 2): s2 = arr(Right(s, 1), 2)
ReDim arr1(1 To Len(s1) * Len(s2), 1 To 1)
For i = 1 To Len(s1)
  For j = 1 To Len(s2)
    r = r + 1
    arr1(r, 1) = Mid(s1, i, 1) & Mid(s2, j, 1)
  Next j
Next i
Range("h6:h" & [h65536].End(3).Row).ClearContents
[h6].Resize(r) = arr1
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Address <> [f3].Address Then Exit Sub
If Target = "" Then Exit Sub
arr = [b5].CurrentRegion
s = Target: s1 = arr(Left(s, 1), 2): s2 = arr(Right(s, 1), 2)
ReDim arr1(1 To Len(s1) * Len(s2), 1 To 1)
For i = 1 To Len(s1)
  For j = 1 To Len(s2)
    r = r + 1
    arr1(r, 1) = Mid(s1, i, 1) & Mid(s2, j, 1)
  Next j
Next i
Range("h6:h" & [h65536].End(3).Row).ClearContents
[h6].Resize(r) = arr1
End Sub

**kero4000** · 12-25-2018, 02:24 AM

sorry that was mistake cause i catch cold

Awesome Code I Add reputation * For You

Could you please add more digits not only 2 digits i nedd for example 5 digits or 7 digits ♥

Thank you very very much

**大灰狼1976** · 12-25-2018, 06:00 PM

Sorry, because of the time difference, i didn't see your reply in time, i will deal with it today.

**大灰狼1976** · 12-25-2018, 06:29 PM

macro code:

Sub bbb()
Dim arr, arr1, arr2, s$, s1$, i&, j&, k&, r&, r1&
arr = [b5].CurrentRegion
s = [f3]: r = 1
ReDim arr2(1 To 1)
For i = Len(s) To 1 Step -1
  s1 = arr(Mid(s, i, 1), 2)
  ReDim arr1(1 To r * Len(s1))
  For j = 1 To Len(s1)
    For k = 1 To UBound(arr2)
      r1 = r1 + 1
      arr1(r1) = Mid(s1, j, 1) & arr2(k)
    Next k
  Next j
  arr2 = arr1
  r = UBound(arr1)
  r1 = 0
Next i
ReDim arr2(1 To UBound(arr1), 1 To 2)
For i = 1 To UBound(arr1)
  arr2(i, 1) = arr1(i)
  arr2(i, 2) = -i
Next i
[h5].CurrentRegion.Offset(1).ClearContents
[h6].Resize(i - 1, 2) = arr2
End Sub

**大灰狼1976** · 12-25-2018, 06:33 PM

worksheet events:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Address <> [f3].Address Then Exit Sub
If Target = "" Then Exit Sub
Dim arr, arr1, arr2, s$, s1$, i&, j&, k&, r&, r1&
arr = [b5].CurrentRegion
s = Target: r = 1
ReDim arr2(1 To 1)
For i = Len(s) To 1 Step -1
  s1 = arr(Mid(s, i, 1), 2)
  ReDim arr1(1 To r * Len(s1))
  For j = 1 To Len(s1)
    For k = 1 To UBound(arr2)
      r1 = r1 + 1
      arr1(r1) = Mid(s1, j, 1) & arr2(k)
    Next k
  Next j
  arr2 = arr1
  r = UBound(arr1)
  r1 = 0
Next i
ReDim arr2(1 To UBound(arr1), 1 To 2)
For i = 1 To UBound(arr1)
  arr2(i, 1) = arr1(i)
  arr2(i, 2) = -i
Next i
[h5].CurrentRegion.Offset(1).ClearContents
[h6].Resize(i - 1, 2) = arr2
End Sub

**kero4000** · 12-26-2018, 12:15 AM

thank you so much dear

i like it so much , could you please show me some explanation on the code ? the main idea ?

i look forward to learn more from your experience

**大灰狼1976** · 12-26-2018, 12:34 AM

Hi kero4000!
I will make notes and other instructions when I am free.

**大灰狼1976** · 12-26-2018, 01:14 AM

Sub bbb()
Dim arr, arr1, arr2, s$, s1$, i&, j&, k&, r&, r1&
arr = [b5].CurrentRegion
s = [f3]: r = 1
ReDim arr2(1 To 1)
'*********************-- key point--*******************  for example: [f3] = "128", then s = "128" too
For i = Len(s) To 1 Step -1                          '*    cycle1:  i=3 , Mid(s, i, 1)="8" , s1="TUV"
  s1 = arr(Mid(s, i, 1), 2)                          '*             arr1=array("T","U","V")
  ReDim arr1(1 To r * Len(s1))                       '*    cycle2:  i=2 , Mid(s, i, 1)="2" , s1="ABC"
  For j = 1 To Len(s1)                               '*             arr1=array("AT","AU","AV","BT","BU","BV","CT","CU","CV")
    For k = 1 To UBound(arr2)                        '*    cycle3:  i=1 , Mid(s, i, 1)="1" then s1=".@"
      r1 = r1 + 1                                    '*             arr1=array(".AT",".AU",".AV",".BT",".BU",".BV",".CT",".CU",".CV","@AT","@AU","@AV","@BT","@BU","@BV","@CT","@CU","@CV")
      arr1(r1) = Mid(s1, j, 1) & arr2(k)             '*
    Next k                                           '*  the main idea: each time the last combination result is recombined with the new string.
  Next j                                             '*
  arr2 = arr1                                        '*
  r = UBound(arr1)                                   '*
  r1 = 0                                             '*
Next i                                               '*
'*********************-- key point--*******************
ReDim arr2(1 To UBound(arr1), 1 To 2)
For i = 1 To UBound(arr1)
  arr2(i, 1) = arr1(i)
  arr2(i, 2) = -i
Next i
[h5].CurrentRegion.Offset(1).ClearContents
[h6].Resize(i - 1, 2) = arr2
End Sub

**kero4000** · 12-26-2018, 03:04 AM

Originally Posted by 大灰狼1976

Sub bbb()
Dim arr, arr1, arr2, s$, s1$, i&, j&, k&, r&, r1&
arr = [b5].CurrentRegion
s = [f3]: r = 1
ReDim arr2(1 To 1)
'*********************-- key point--*******************  for example: [f3] = "128", then s = "128" too
For i = Len(s) To 1 Step -1                          '*    cycle1:  i=3 , Mid(s, i, 1)="8" , s1="TUV"
  s1 = arr(Mid(s, i, 1), 2)                          '*             arr1=array("T","U","V")
  ReDim arr1(1 To r * Len(s1))                       '*    cycle2:  i=2 , Mid(s, i, 1)="2" , s1="ABC"
  For j = 1 To Len(s1)                               '*             arr1=array("AT","AU","AV","BT","BU","BV","CT","CU","CV")
    For k = 1 To UBound(arr2)                        '*    cycle3:  i=1 , Mid(s, i, 1)="1" then s1=".@"
      r1 = r1 + 1                                    '*             arr1=array(".AT",".AU",".AV",".BT",".BU",".BV",".CT",".CU",".CV","@AT","@AU","@AV","@BT","@BU","@BV","@CT","@CU","@CV")
      arr1(r1) = Mid(s1, j, 1) & arr2(k)             '*
    Next k                                           '*  the main idea: each time the last combination result is recombined with the new string.
  Next j                                             '*
  arr2 = arr1                                        '*
  r = UBound(arr1)                                   '*
  r1 = 0                                             '*
Next i                                               '*
'*********************-- key point--*******************
ReDim arr2(1 To UBound(arr1), 1 To 2)
For i = 1 To UBound(arr1)
  arr2(i, 1) = arr1(i)
  arr2(i, 2) = -i
Next i
[h5].CurrentRegion.Offset(1).ClearContents
[h6].Resize(i - 1, 2) = arr2
End Sub

Thanks alot ♥

Thread: Possible Combination

Thread Tools

Display

Possible Combination

Posting Permissions