счастливый билет

Private Sub Комманда1_Click()
Dim I, J
Dim Bil As String, SimN As String, SimK As String, SumN As Byte, SumK As Byte
 
Список1.Clear
For J = 1001 To 999999
 
    Bil = IIf(Len(J) = 4, "00" & J, IIf(Len(J) = 5, "0" & J, J))
    SumN = 0
    SumK = 0
    For I = 1 To 3
        SimN = Mid(Bil, I, 1)
        SimK = Mid(Bil, I + 3, 1)
        SumN = Val(SumN) + Val(SimN)
        SumK = Val(SumK) + Val(SimK)
 
    Next I
          If SumN = SumK Then Список1.AddItem Bil: k = k + 1
Next J
MsgBox k, vbOKOnly, "Таких билетов"
End Sub

Sub Комбинаторика_Рулит()
   Dim StartTime As Date
   Dim x1 As Byte, x2 As Byte, x3 As Byte, x4 As Byte, xMax As Byte, sMax As Byte
   Dim s As Byte
   Dim i As Integer
   Dim N As Long
 
   xMax = 9: sMax = 36
   StartTime = Timer
 
   For s = 0 To sMax
      i = 0
      For x4 = 0 To xMax
         For x3 = 0 To xMax
            For x2 = 0 To xMax
               For x1 = 0 To xMax
                  If s = x1 + x2 + x3 + x4 Then i = i + 1
               Next x1
            Next x2
         Next x3
      Next x4
      N = N + i ^ 2
   Next s
   '-----------
   MsgBox "Процедура выполнялась " & vbNewLine _
          & Format(Timer - StartTime, "0.000") & " сек", , N & " билетов"
End Sub

Public Sub a()
t = Timer
 
Dim arr(9999, 1) As Long
Dim I As Long, J As Long, k As Long, h As Long
    For I = 0 To 9
        For J = 0 To 9
            For k = 0 To 9
                For h = 0 To 9
                    arr(n, 0) = I + J + k + h
                    arr(n, 1) = n
                    n = n + 1
                Next h
            Next k
        Next J
    Next I
 
Debug.Print Timer - t
SortArr arr, adInteger, "0 ASC"
Debug.Print Timer - t
    
Dim Bil(4816029) As Long: n = 0: k = 0: h = 0
 
For I = 0 To 9999
    For J = 0 To 9999
        Bil(k) = arr(I, 1) * 10000& + arr(n, 1)
        k = k + 1
        If arr(n, 0) <> arr(n + 1, 0) Then
            h = IIf(I = n, n + 1, h)
            n = n + 1
            Exit For
        End If
        n = n + 1
    Next J
    n = h
    If n = 9999 Then Exit For
Next I
Bil(k) = arr(I + 1, 1) * 10000& + arr(n, 1) ' óæå íåò ñèë êóäà-òî ýòî ïðàâèëüíî âïèñûâàòü :)
 
Debug.Print "âðåìÿ âûïîëíåíèÿ - " & Timer - t & "ñ. â ìàññèâå âñå ñ÷àñòëèâûå íîìåðà"
Debug.Assert 0
    
End Sub
'ôóíêöèÿ ñîðòèðîâêè
 
Public Sub SortArr(ByRef myArr, arrDataType, strSort As String)
Dim x, I, y, myArrS
Dim rst As New ADODB.Recordset
 
With rst
'Ñîçäàåì ðåêîðäñåò
  With .Fields
      x = LBound(myArr, 2)
'      For Each myArrS In arrDataType
'         If myArrS = 129 Or myArrS = 200 Then
            .Append 0, adInteger '.Append X, myArrS, 255
'         Else
            .Append 1, adInteger '.Append X, myArrS
'         End If
            'X = X + 1
'      Next
  End With
  .CursorLocation = adUseClient
  .Open
        
'Çàïîëíÿåì ðåêîðäñåò
    For I = LBound(myArr, 1) To UBound(myArr, 1)
      .AddNew
      For y = 0 To UBound(myArr, 2) - LBound(myArr, 2)
        .Fields(y) = myArr(I, y + LBound(myArr, 2))
      Next y
   Next I
        
'Ñîðòèðóåì
        .Sort = strSort
        .MoveFirst
'Çàïîëíÿåì ìàññèâ
   For I = LBound(myArr, 1) To UBound(myArr, 1)
      For y = 0 To UBound(myArr, 2) - LBound(myArr, 2)
         myArr(I, y + LBound(myArr, 2)) = Trim$(.Fields(y))
      Next y
      .MoveNext
   Next I
        
   .Close
End With
Set rst = Nothing
End Sub

Public Sub раз_ивсе()
t = Timer
 
Dim arr(999, 1) As Long
Dim i As Long, j As Long, k As Long
    For i = 0 To 9
        For j = 0 To 9
            For k = 0 To 9
                arr(n, 0) = i + j + k
                arr(n, 1) = n
                n = n + 1
            Next k
        Next j
    Next i
 
SortArr arr, adInteger, "0 ASC"
    
Dim bil(55252) As Long: n = 0: k = 0
 
For i = 0 To 999
    For j = n To 999
        bil(k) = arr(i, 1) * 1000& + arr(n, 1)
        k = k + 1
        If arr(n, 0) <> arr(n + 1, 0) Then
            h = IIf(i = n, n + 1, h)
            n = n + 1
            Exit For
        End If
        n = n + 1
    Next j
    n = h
    If n = 999 Then Exit For
Next i
bil(k) = arr(i + 1, 1) * 1000& + arr(n, 1) ' уже нет сил :)
 
Debug.Print "время выполнения - " & Timer - t & "с. в массиве все счастливые номера"
Debug.Assert 0    
End Sub

bil(k) = arr(i, 1) * 1000& + arr(n, 1)

 I = UBound(Bil)
 Debug.Print I
 t = Timer
 For I = 0 To UBound(Bil) - 1
 If Bil(I) = 0 Then
 I = I
 End If
 Debug.Print I, Bil(I)
 Next I
 Debug.Print "время выполнения - " & Timer - t
End Sub

t = Timer ' ýòî äëÿ èçìåðåíèÿ âðåìåíè
 
Dim arr(999, 1) As Long ' â ýòîì öèêëå ïîëó÷àåì âñå ïåðåñòàíîâêè èç òðåõ öèôð âî âòîðîì ïîëå ìàññèâà
Dim i As Long, j As Long, k As Long   ' è çàîäíî ñóììó êàæäîé ïåðåñòàíîâêè â ïåðâîì ïîëå
    For i = 0 To 9
        For j = 0 To 9
            For k = 0 To 9
                arr(n, 0) = i + j + k
                arr(n, 1) = n
                n = n + 1
            Next k
        Next j
    Next i
 
SortArr arr, adInteger, "0 ASC" ' ñîðòèðóåì ìàññèâ ïî ïîëþ ñ ñóììîé ïåðåñòàíîâêè ïî âîçðàñòàíèþ(õîòÿ è ïî óáûâàíèþ, íàâåðíî, áóäåò ðàáîòàòü).
'êîä ñîðòèðîâêè ñòûðèë íà ñîñåäíåì ôîðóìå. ñîðòèðîâêà èäåò ìåòîäîì âèðòóàëüíîãî ðåêîðäñåòà. íóæíî â ðåôåðåíñàõ óñòàíîâèòü
' ññûëó íà "microsoft ActiveX Data Object 2.8".
'íó èëè ñîðòèðîâàòü ëþáûì äðóãèì ñïîñîáîì
    
Dim bil(55252) As Long: n = 0: k = 0 ' áå... ïîâòîðíîå èñïîëüçîâàíèå ïåðåìåííûõ
 
For i = 0 To 999  ' â ýòîì öèêëå ôîðìèðóåì íîìåðà ñ÷. áèëëåòîâ ïóòåì ïåðåáîðà âñåõ ñî÷åòàíèé ïåðåñòàíîâîê ñ îäèíàêîâîé ñóììîé
    For j = n To 999
        bil(k) = arr(i, 1) * 1000& + arr(n, 1) ' ê êàæäîé ïåðåñòàíîâêå ïðèñîåäèíÿåì âñå ïåðåñòàíîâêè ñ òàêîé æå ñóììîé
        k = k + 1
        If arr(n, 0) <> arr(n + 1, 0) Then ' ïåðåñòàíîâêè îòñîðòèðîâàíû, ïîýòîìó ïðè èçìåíåíèè ñóììû â n-òîì ýëåìåíòå ìàññèâà ïåðåõîäèì ê ñëåäóþùåìó i
            h = IIf(i = n, n + 1, h)
            n = n + 1
            Exit For
        End If
        n = n + 1
    Next j
    n = h
    If n = 999 Then Exit For
Next i
bil(k) = arr(i + 1, 1) * 1000& + arr(n, 1) ' ??? ??? ??? :)
 
Debug.Print "????? ?????????? - " & Timer - t & "?. ? ??????? ??? ?????????? ??????"
Debug.Assert 0 ' вот здесь оно остановиться, и в Wath Window можно будет посмотреть массив