August Challenge of the Month Discussion

IOANNIS · Sep 2, 2002

..The Final Macro ..
This message was edited by IOANNIS on 2002-09-03 01:15

IOANNIS · Sep 2, 2002

.. Something goes wrong .. with copy-paste ..

it replace the "8)" with a red face ??

IOANNIS · Sep 2, 2002

is there a bug on Colo's cool utility for displaying Excel Worksheet on the board ??

IOANNIS · Sep 2, 2002

BRUTE_FORCE_FINAL.xls

J

K

L

M

1

2

August 2002 Challenge

IOANNIS · Sep 2, 2002

RichardS · Sep 2, 2002

Disable smilies on your post.

Richard

IOANNIS · Sep 3, 2002

.. THE FINAL MACRO ..
.. Module 1 ...

Code:

Dim INV() As Long
Dim CHECK As Long
Dim MAX_CHECK_INVS_No As Integer
Dim Sol As Long
Dim RESUME_No() As Integer
Dim RES_No As Integer
Dim RESUME_CALC As Integer
Dim MAX_RESUME_No As Integer
Dim AA As Long
Dim MAX_INVS As Integer
Dim MAX_DEPTH As Integer


Sub Challenge()

' SORTING
Columns("B:B").Select
    Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

' CLEAR SOLUTION AREA

Columns("H:H").Select
Selection.ClearContents

Columns("M:P").Select
Selection.ClearContents

Cells(11, 4).Select
Selection.Activate

Cells(18, 6) = 0
Cells(7, 6) = 0
CHECK = Cells(2, 6) * 100

TOT_INV = Cells(1, 6)
ReDim INV(TOT_INV + 1)

MaxSum = 0

For i = 1 To TOT_INV
   INV(i) = Cells(i, 2) * 100
   MaxSum = MaxSum + INV(i)
Next

SUM_INV = 0

MAX_INVS = 0

For i = 1 To TOT_INV
   SUM_INV = SUM_INV + INV(i)
   If SUM_INV = CHECK Then MAX_INVS = i: Exit For
   If SUM_INV > CHECK Then MAX_INVS = i - 1: Exit For
Next

Cells(3, 6) = MAX_INVS

MAX_CHECK_INVS_No = 1
i = 1

For i = TOT_INV To 2 Step -1
    SUM_INV = INV(i)
    If SUM_INV = CHECK Then GoTo Exit_for
    For k = 1 To i
        SUM_INV = SUM_INV + INV(k)
        If SUM_INV <= CHECK Then
           GoTo Exit_for
        End If
    Next
Next

Exit_for:
MAX_CHECK_INVS_No = i

INV(MAX_CHECK_INVS_No + 1) = MaxSum

Cells(4, 6) = MAX_CHECK_INVS_No

Sol = 0
AA = 0

Cells(14, 6) = Time

'Application.ScreenUpdating = False

    Find_Sol 0, "", 0
    
    Cells(10, 5) = Str(MAX_CHECK_INVS_No)
    Cells(15, 6) = Time
    
Application.ScreenUpdating = True

End Sub
    
Sub Find_Sol(No_01 As Integer, NN_01 As String, SINVS_01 As Long)
 
For No_02% = No_01 + 1 To MAX_CHECK_INVS_No
    
    NN_02$ = NN_01 + Str(No_02%)
    SINVS_02& = SINVS_01 + INV(No_02%)
        
    If SINVS_02& > CHECK Then Exit For
    If SINVS_02& = CHECK Then
       Sol = Sol + 1
       If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
       
       Cells(Sol, 8) = NN_02$
       'Cells(10, 5) = NN_02$
       Cells(15, 6) = Time
                     
    End If
    
    If (SINVS_02& + INV(No_02% + 1)) > CHECK Then
          
       If (INV(No_02%) = INV(No_02% + 1)) Then GoTo END_LOOP
       
       MAX_No_01% = MAX_CHECK_INVS_No + 1
       No_02% = No_02% + 1
       
START_LOOP:
      
       CH_No% = MAX_No_01% - No_02%
       
       If CH_No% > 1 Then
          CH_No_m% = CH_No% / 2 + No_02%
      
          If (SINVS_01 + INV(CH_No_m%)) > CHECK Then
             MAX_No_01% = CH_No_m%
             GoTo START_LOOP
          End If
          If (SINVS_01 + INV(CH_No_m%)) = CHECK Then
             Sol = Sol + 1
             If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
             Cells(Sol, 8) = NN_01 + Str(CH_No_m%)
             Exit For
          End If
          If (SINVS_01 + INV(CH_No_m%)) < CHECK Then
             No_02% = CH_No_m%
             GoTo START_LOOP
          End If
        Else
          If CH_No% = 1 Then
             No_02% = MAX_No_01% - 1
             If (SINVS_01 + INV(No_02%)) = CHECK Then
                Sol = Sol + 1
                If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
                   Cells(Sol, 8) = NN_01 + Str(No_02%)
                  Exit For
                End If
             End If
             Exit For
          End If
       End If
END_LOOP:
    
    Find_Sol No_02%, NN_02$, SINVS_02&
   
Next_No_02:
Next No_02

End Sub


Sub RESUME_LAST_SOLUTION()

TOT_INV = Cells(1, 6)

ReDim RESUME_No(TOT_INV)

LAST_SOLUTION_No = Cells(5, 6)
If LAST_SOLUTION_No = 0 Then Exit Sub
LAST_SOLUTION = Cells(LAST_SOLUTION_No, 8)

Range("D:D").Select
Selection.ClearContents

If LAST_SOLUTION <> "" Then

LAST_SOLUTION = Trim(LAST_SOLUTION) + " "

SOL_LEN = Len(LAST_SOLUTION)
START_LEN = 1

AA = 1
For i = START_LEN To SOL_LEN

No = InStr(i, LAST_SOLUTION, " ")

Cells(AA, 4) = Mid(LAST_SOLUTION, i, No - i)
RESUME_No(AA) = Cells(AA, 4)
i = No
AA = AA + 1

Next

End If


End Sub
Sub COPY_SOLUTIONS()

AC_NAME = ActiveSheet.Name

N = 0
SOL_NAME = Cells(2, 6)

Do
  N = N + 1
  SOL_NAME_01 = Trim(Str(SOL_NAME)) + "_" + Trim(Str(N))
Loop Until Exist_SHEET(SOL_NAME_01) = 0

Cells(7, 6) = N

Create_SOLUTIONS_PAGE (SOL_NAME_01)

Sheets(AC_NAME).Select
Range("H1:I65536").Select
Selection.Copy

Sheets(SOL_NAME_01).Select
Range("B1").Select
ActiveSheet.Paste
Columns("B:C").AutoFit
Range("B1").Select

Sheets(AC_NAME).Select
Range("H1:I65536").Select
Selection.ClearContents
Range("E10").Activate

End Sub
Function Exist_SHEET(SH_NAME)

Exist_SHEET = 0

For Each SH In Sheets
    If SH.Name = SH_NAME Then Exist_SHEET = 1: Exit For
Next SH
 
End Function

Sub Create_SOLUTIONS_PAGE(SH_NAME)

If Exist_SHEET(SH_NAME) Then
   Else
       Set NewSheet = Worksheets.Add
       NewSheet.Name = SH_NAME
End If

End Sub

Sub RESUME_Challenge()

If Cells(5, 6) = 0 Then Exit Sub

' SORTING
Columns("B:B").Select
    Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

RESUME_LAST_SOLUTION

RESUME_CALC = 1

Cells(11, 4).Select
Selection.Activate

MAX_RESUME_No = Cells(8, 6)

CHECK = Cells(2, 6) * 100

TOT_INV = Cells(1, 6)
ReDim INV(TOT_INV + 1)

MaxSum = 0
For i = 1 To TOT_INV
    INV(i) = Cells(i, 2) * 100
    MaxSum = MaxSum + INV(i)
Next

SUM_INV = 0

MAX_INVS = 0

For i = 1 To TOT_INV
   SUM_INV = SUM_INV + INV(i)
   If SUM_INV = CHECK Then MAX_INVS = i: Exit For
   If SUM_INV > CHECK Then MAX_INVS = i - 1: Exit For
Next

Cells(3, 6) = MAX_INVS

MAX_CHECK_INVS_No = 1

For i = TOT_INV To 2 Step -1
    SUM_INV = INV(i)
    If SUM_INV = CHECK Then GoTo Exit_for
    For k = 1 To i
        SUM_INV = SUM_INV + INV(k)
        If SUM_INV <= CHECK Then
           GoTo Exit_for
        End If
    Next
Next_i:
Next
Exit_for:
MAX_CHECK_INVS_No = i
INV(MAX_CHECK_INVS_No + 1) = MaxSum

Cells(4, 6) = MAX_CHECK_INVS_No

CHECK = MaxSum * 2
RES_No = 0
Sol = Cells(5, 6)

Cells(18, 6).Value = Cells(19, 6).Value

Cells(14, 6) = Time
No_01% = RESUME_No(1)

'Application.ScreenUpdating = False

    RESUME_Find_Sol No_01%, "", 0

    Cells(10, 5) = Str(MAX_CHECK_INVS_No)
    Cells(15, 6) = Time
    
Application.ScreenUpdating = True

End Sub
    
Sub RESUME_Find_Sol(No_01 As Integer, NN_01 As String, SINVS_01 As Long)
    
For No_02% = No_01 + 1 To MAX_CHECK_INVS_No
    
    If RESUME_CALC = 1 Then
       RES_No = RES_No + 1
       If RES_No > MAX_RESUME_No Then
             RESUME_CALC = 2
             CHECK = Cells(2, 6) * 100
             No_02% = No_02% - 1
             Exit For
         Else
            No_02% = RESUME_No(RES_No)
       End If
    End If
    

    NN_02$ = NN_01 + Str(No_02%)
    SINVS_02& = SINVS_01 + INV(No_02%)
    
    If SINVS_02& > CHECK Then Exit For
    If SINVS_02& = CHECK Then
       Sol = Sol + 1
       If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
       
       Cells(Sol, 8) = NN_02$
       'Cells(10, 5) = NN_02$
       Cells(15, 6) = Time
                 
    End If
        
    If (SINVS_02& + INV(No_02% + 1)) > CHECK Then
           
       If (INV(No_02%) = INV(No_02% + 1)) Then GoTo END_LOOP
       
       MAX_No_01% = MAX_CHECK_INVS_No + 1
       No_02% = No_02% + 1
       
START_LOOP:
      
       CH_No% = MAX_No_01% - No_02%
       
       If CH_No% > 1 Then
          CH_No_m% = CH_No% / 2 + No_02%
      
          If (SINVS_01 + INV(CH_No_m%)) > CHECK Then
             MAX_No_01% = CH_No_m%
             GoTo START_LOOP
          End If
          If (SINVS_01 + INV(CH_No_m%)) = CHECK Then
             Sol = Sol + 1
             If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
             Cells(Sol, 8) = NN_01 + Str(CH_No_m%)
             Exit For
          End If
          If (SINVS_01 + INV(CH_No_m%)) < CHECK Then
             No_02% = CH_No_m%
             GoTo START_LOOP
          End If
        Else
          If CH_No% = 1 Then
             No_02% = MAX_No_01% - 1
             If (SINVS_01 + INV(No_02%)) = CHECK Then
                Sol = Sol + 1
                If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
                   Cells(Sol, 8) = NN_01 + Str(No_02%)
                  Exit For
                End If
             End If
             Exit For
          End If
       End If
END_LOOP:
         
    RESUME_Find_Sol No_02%, NN_02$, SINVS_02&

Next_No_02:
Next No_02

End Sub

.. Module 2 ...

Code:

Dim Comp_No()
Function Print_No(Combination As String, Base As Integer) As Variant

Application.ScreenUpdating = False

Dim COMP As Integer
Dim Max_COMP As Integer
Dim ss, dd, i, k As Integer
Dim Co_02, Co_01 As Integer

Max_COMP = Val(SEPARATE_COMP(Combination, 0))
ReDim Comp_No(Max_COMP)

Dim Comp_SER(10, 2)

For COMP = 1 To Max_COMP
    Comp_No(COMP) = Val(SEPARATE_COMP(Combination, COMP))
Next

ss = 0: dd = 0

Select Case Max_COMP
 Case 1
      Print_No = CDec(1)
      For COMP = 1 To Comp_No(1) - 1
          Print_No = CDec(Print_No + Count_Combinations(COMP, Base))
      Next
 Case Base: Print_No = CDec(Max_COMP)
 Case Else
      Co_01 = Comp_No(1)
      For i = 2 To Max_COMP
          Co_02 = Comp_No(i)
          If Co_02 - Co_01 = 1 Then
                Co_01 = Co_02
                dd = dd + 1
            Else
                ss = ss + 1
                Comp_SER(ss, 1) = Co_01
                Comp_SER(ss, 2) = Co_02
                Co_01 = Co_02
          End If
      Next
      If ss = 0 Then
            Print_No = CDec(Max_COMP)
            For COMP = 1 To Comp_No(1) - 1
                Print_No = CDec(Print_No + Count_Combinations(COMP, Base))
            Next
        Else
            Print_No = CDec(Print_No + Max_COMP)
            For i = 1 To ss
                For k = Comp_SER(i, 1) + 1 To Comp_SER(i, 2) - 1
                   Print_No = CDec(Print_No + Count_Combinations(k, Base))
                Next
            Next
            For COMP = 1 To Comp_No(1) - 1
                Print_No = CDec(Print_No + Count_Combinations(COMP, Base))
            Next
            
      End If
End Select

Application.ScreenUpdating = True

End Function

Function Count_Combinations(No As Integer, Base As Integer) As Variant

Count_Combinations = CDec(2 ^ (Base - No))

End Function

Function SEPARATE_COMP(CELL_TEXT As String, No As Integer) As String
Application.ScreenUpdating = False

If CELL_TEXT = "" Then SEPARATE_COMP = "": Exit Function

' COUNT WORDS

CELL_TEXT = Trim(CELL_TEXT) + " "
TEXT_LEN% = Len(CELL_TEXT)
START_LEN% = 1
COUNTER_No% = 1
For i% = START_LEN% To TEXT_LEN%
    FOUNT_POSITION_No% = InStr(i%, CELL_TEXT, " ")
    WORD_FOUND = Mid(CELL_TEXT, i%, FOUNT_POSITION_No% - i%)
    i% = FOUNT_POSITION_No%
    If Trim(WORD_FOUND) <> "" Then
       COUNTER_No% = COUNTER_No% + 1
    End If
Next

MAX_WORDS% = COUNTER_No% - 1

If No = 0 Then
   SEPARATE_COMP = MAX_WORDS%
   Application.ScreenUpdating = True
   Exit Function
End If

' PUT WORDS IN ARRAY
ReDim WORDS_FOUND(MAX_WORDS%)

START_LEN% = 1
COUNTER_No% = 1

For i% = START_LEN% To TEXT_LEN%
   FOUNT_POSITION_No% = InStr(i%, CELL_TEXT, " ")
   WORD_FOUND = Mid(CELL_TEXT, i%, FOUNT_POSITION_No% - i%)
   i% = FOUNT_POSITION_No%
   If Trim(WORD_FOUND) <> "" Then
      WORDS_FOUND(COUNTER_No%) = WORD_FOUND
      COUNTER_No% = COUNTER_No% + 1
   End If
Next

If No > MAX_WORDS% Then No = MAX_WORDS%
SEPARATE_COMP = WORDS_FOUND(No)
    
Application.ScreenUpdating = True

End Function

.. Create two Modules and copy the code above to them ..

IOANNIS · Sep 3, 2002

BRUTE_FORCE_FINAL.xls

A

B

C

D

E

F

G

H

1

77,740

RES_01

TOTALINVOCIES

54

12345678910111213141518203436

2

83,060

RES_02

CHECK

4556,92

12345678910111213141619232838

3

89,400

RES_03

MAX_SUM_NUMBERS

21

12345678910111213151617182445

4

116,140

RES_04

MAX_CHECK_No

53

123456789101112131617283340

5

126,690

RES_05

CURRENTSHEET_SOLUTIONS

84

123456789101112131622262744

6

144,770

RES_06

TOTAL_SOLUTIONS_FOUND

84

1234567891011121317283649

7

160,620

RES_07

TOTALSHEETSOLUTIONS

0

1234567891011121325313641

8

185,580

RES_08

MAX_RESUME_No

0

123456789101112141522242746

9

192,650

RES_09

LASTSOLUTIONFOUNDorCOMBINATION

123456789101112141617213346

10

194,580

RES_10

53

1234567891011121420284144

11

219,100

RES_11

CHECKEDCOMBINATIONS

=Print_No(E10;F4)

12345678910111215162022242728

12

222,520

RES_12

TOTAL_COMBINATIONS

9.007.199.254.740.990

12345678910111215171920212436

13

228,310

RES_13

COMBINATION'S%DONE

=(F11/F12)*100

1234567891011121718343738

14

230,720

RES_14

MACRO'STIMESTART

11:25:32

1234567891011121721233249

15

244,220

RES_15

LASTFOUNDSOLUTION'STIME

11:25:35

1234567891011122426273042

16

280,710

RES_16

ELAPSEDTIME

0:00:03

123456789101113141618193148

17

324,840

RES_17

REMAINTIME

=F19*((100-F13)/F13)

123456789101113141823283035

18

329,170

RES_18

LASTRESUMETIME

0:00:00

1234567891011131424263348

19

329,970

RES_19

TOTALCALCTIME

0:00:03

1234567891011131516373842

20

346,350

RES_20

SOLUTION'SSPEED/HOUR

100.800

1234567891011131518264246

21

365,430

RES_21

1234567891011131824313537

22

409,170

RES_22

1234567891011132021293243

23

440,930

RES_23

1234567891011141517194647

24

441,430

RES_24

12345678910111415172021222631

25

444,980

RES_25

123456789101114151821252645

26

456,680

RES_26

1234567891011141617293546

August 2002 Challenge

IOANNIS · Sep 3, 2002

.. Create a sheet similar to the above screen shot..

..Copy formulas to the same cells ..

..Format the time's cells as time "h:mm:ss"

..Create two Buttons
..One with a Name "Find New" and assign the macro "Challenge"
..and the second one with a Name "Resume" with the macro "RESUME_Challenge"

The macro uses the "numbers" and the "check" on the sheet (you can replace the "numbers" or the "check" as you wish")

The resume button works only if there is one solution found and the state off VBA is not debug

The resume macro is a little bit slower

If "Application.ScreenUpdating = False" you cant see anything unless you break the code with [ctrl]+[break]

The Macro uses two filtters ..

1: If SINVS_02& > CHECK Then Exit For
2: If (SINVS_02& + INV(No_02% + 1)) > CHECK Then
..at this point the macro use the dividing method (i think this is the name)

If you Want more infos just let me know ..

_________________
ATHENS 2004
This message was edited by IOANNIS on 2002-09-03 01:43
This message was edited by IOANNIS on 2002-09-03 08:44

IOANNIS · Sep 3, 2002

............
If you Enable the formulas in cells
1:f11
2:f13
3:f17

you have to un remark the line in the code below
Cells(Sol, 8) = NN_02$
=> 'Cells(10, 5) = NN_02$
Cells(15, 6) = Time

...........

_________________
ATHENS 2004
This message was edited by IOANNIS on 2002-09-03 01:58

August Challenge of the Month Discussion

IOANNIS

Board Regular

Excel Facts

IOANNIS

Board Regular

IOANNIS

Board Regular

IOANNIS

Board Regular

IOANNIS

Board Regular

RichardS

Well-known Member

IOANNIS

Board Regular

IOANNIS

Board Regular

IOANNIS

Board Regular

IOANNIS

Board Regular

Forum statistics

Share this page

August Challenge of the Month Discussion

Board Regular

Excel Facts

Board Regular

Board Regular

Board Regular

Board Regular

Well-known Member

Board Regular

Board Regular

Board Regular

Board Regular

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock