Can this Code be Condensed

[Joel]

I got the variabbles cnts and counts mixed up. counts should be dimennsioned
as 11 because in the the number of Map you have

Private Counts(11) As Integer

 

[Paul Black]

Thanks Joel,

I had to change ...

Private Counts(11) As Integer

.... to ...

Private Counts(11) As Long

.... because it gave an overflow error 6. After changing that all works
great, thank you.

All the Best.
Paul

 

[Dana DeLouis]

Hi. Your code took 58 Seconds for me.
The following did it in 25 Seconds.
This is just 1 of many other ideas. There are 11 Integer Partitions of the
number 6, as your Map() variable holds. I took the Permutations of each
pattern, for a total of 32 possible patterns (0's removed). The idea was to
remove the Sort.
This is still not efficient because I'm still counting A,B,C...on each loop,
although they don't change as fast. I'm tried to change the count of each
variable A,B,C...etc as each variable changes, but I'm having a hard time
with the logic.
Note that there are 3003 possible patterns if we keep the 0's in the count
array. This is easy in other programs, but a little hard to do with Excel.
Anyway, here's my first attempt.

Option Explicit

Sub First_Digit_v2()
Dim A As Integer, B As Integer, C As Integer
Dim D As Integer, E As Integer, F As Integer

Dim n As Long
Dim x As Long
Dim y As Long

Dim Tme As Double 'For Start Time
Dim pIn As Variant 'Pattern In
Dim pOut As Variant 'Pattern Out
Dim P(1 To 11) As Long 'Count of Patterns
Dim M(1 To 49) As Long 'First Digits (1-49)
Dim T(1 To 9) As Long 'Count of Digits(1-9)
Dim Dic 'Dictionary Object

Set Dic = CreateObject("Scripting.Dictionary")
Tme = Timer

'// Build Lookup Table
'// Pattern Input
pIn = Array( _
6, 51, 15, 42, 24, 411, 141, _
114, 33, 321, 312, 231, 213, 132, 123, 3111, _
1311, 1131, 1113, 222, 2211, 2121, 2112, 1221, _
1212, 1122, 21111, 12111, 11211, 11121, 11112, 111111)

'// Pattern Output
pOut = Array( _
11, 10, 10, 9, 9, 8, 8, 8, 7, 6, 6, 6, 6, 6, 6, _
5, 5, 5, 5, 4, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 1)

For n = 1 To 32
Dic.Add pIn(n - 1), pOut(n - 1)
Next n

'// Load First Digits
For n = 1 To 49
If n <= 9 Then
M(n) = n
Else
M(n) = n \ 10
End If
Next n

For A = 1 To 44
For B = A + 1 To 45
For C = B + 1 To 46
For D = C + 1 To 47
For E = D + 1 To 48
For F = E + 1 To 49
Erase T
T(M(A)) = 1
T(M(B)) = T(M(B)) + 1
T(M(C)) = T(M(C)) + 1
T(M(D)) = T(M(D)) + 1
T(M(E)) = T(M(E)) + 1
T(M(F)) = T(M(F)) + 1

x = 0
For n = 1 To 9
If T(n) > 0 Then x = x * 10 + T(n)
Next n
y = Dic(x)
P(y) = P(y) + 1
Next F, E, D, C, B, A

For n = 1 To 11
Cells(n, 3) = P(n)
Next
Debug.Print Timer - Tme
End Sub

 

[D-C Dave]

I know this is a long thread and I'm late.
I'd like to enter this recursive approach.

Option Explicit

Dim ntype&(70)

Sub Main()
Dim zSum&, zStart#, i%
For i = 11 To 70
ntype(i) = 0
Next i
zStart = Timer
Application.ScreenUpdating = False
Range("B4").Select
Call Sub1(0, 1, 1) ' sum, first, level
For i = 11 To 70
ActiveCell.Offset(0, 0).Value = "Sum Of Digits ="
ActiveCell.Offset(0, 1).Value = i
ActiveCell.Offset(0, 2).Value = ntype(i)
ActiveCell.Offset(1, 0).Select
zSum = zSum + ntype(i)
Next i
ActiveCell.Offset(0, 0).Value = "Total Combinations Produced"
ActiveCell.Offset(0, 2).Value = zSum
ActiveCell.Offset(2, 0) = "This Program Took " & _
Format(((Timer - zStart) / 24 / 60 / 60), "hh:mm:ss") & " To Process "
Range("B68").Select
Application.ScreenUpdating = True
End Sub

Sub Sub1(pSum%, pFirst%, pLevel%)
Dim i1%
If pLevel < 7 Then
' recursively call sub1
For i1 = pFirst To 43 + pLevel
Call Sub1(pSum + i1 \ 10 + i1 Mod 10, i1 + 1, pLevel + 1)
Next i1
Exit Sub
End If
' level 7: add 1 to ntype
ntype(pSum) = ntype(pSum) + 1
End Sub
[snip]
[SNIP SNIP]