PDA

View Full Version : [SOLVED] 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 23463

大灰狼1976
12-24-2018, 07:44 PM
Hi kero4000!
I can't find the law,Can you explain the result after type in 12?:think:

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?:think:

大灰狼1976
12-25-2018, 12:31 AM
Please refer to the code below. You can use macro or worksheet events.
:yes

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.:yes

大灰狼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 :clap:

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

i look forward to learn more from your experience :yes

大灰狼1976
12-26-2018, 12:34 AM
Hi kero4000!
I will make notes and other instructions when I am free.:yes

大灰狼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
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 ♥