Михаил И. (Все сообщения пользователя)

Sixteen Puzzle Game, (игра шестнашки)

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

15.05.2023 13:39:33

Код

'Program Name:      sixteen
'Purpose:           Entertainment puzzle game
'Author:            Mikhail I.
'Country:           Russian Federation
'Date:              7.12.2009
'Version:           1.0
'File Size:         ...

Private Sub Worksheet_Activate()

    Columns("A:A").Select
    Selection.ColumnWidth = 8
    Columns("B:B").Select
    Selection.ColumnWidth = 1
    Columns("C:H").Select
    Selection.ColumnWidth = 8
    Columns("I:I").Select
    Selection.ColumnWidth = 1

    Rows("1:1").Select
    Selection.RowHeight = 40
    Rows("2:2").Select
    Selection.RowHeight = 3
    Rows("3:10").Select
    Selection.RowHeight = 40
    ActiveWindow.SmallScroll Down:=1
    Rows("11:11").Select
    Selection.RowHeight = 1
    ActiveWindow.ScrollRow = 1

    Range("C3").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("C5").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B5").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B6").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B7").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B8").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("C8").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B9").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("C9").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("H9").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("I9").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("H8").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("I8").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("H7").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("I7").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("I6").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("I5").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("H5").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("I4").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("H4").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("I3").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("H3").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("A1").Select

    Range("D1").Select
    ActiveCell.FormulaR1C1 = "/\"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "/\"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "/\"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "/\"
    Range("D10").Select
    ActiveCell.FormulaR1C1 = "\/"
    Range("E10").Select
    ActiveCell.FormulaR1C1 = "\/"
    Range("F10").Select
    ActiveCell.FormulaR1C1 = "\/"
    Range("G10").Select
    ActiveCell.FormulaR1C1 = "\/"

    Range("D1:G1,D10:G10").Select

    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Arial Black"
        .Size = 36
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

    Union(Range( _
        "I4,I3,H3,I2,H2,G2,F2,E2,D2,C2,B2,B1:I1,B3,C3,B4,C4,B5,C5,B6,B7,C7,B8,C8,B9,C9,B10,C10,D10,E10,F10,G10,H10" _
        ), Range("I10,I9,H9,H8,I8,I7,H7,I6,I5,H5,H4")).Select
    Range("B2").Activate
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 32768
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

    Range("B3:B9,C3,C4,C5,C7,C8,C9,H9,I9,I8,H8,H7,I7,I6,I5,H5,H4,I4,I3,H3").Select
    Range("H3").Activate
    With Selection.Font
        .Color = -16744448
        .TintAndShade = 0
    End With

    Range("D3").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("E3").Select
    ActiveCell.FormulaR1C1 = "2"
    Range("F3").Select
    ActiveCell.FormulaR1C1 = "3"
    Range("G3").Select
    ActiveCell.FormulaR1C1 = "4"
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "5"
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "6"
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "7"
    Range("G4").Select
    ActiveCell.FormulaR1C1 = "8"
    Range("D5").Select
    ActiveCell.FormulaR1C1 = "9"
    Range("E5").Select
    ActiveCell.FormulaR1C1 = "10"
    Range("F5").Select
    ActiveCell.FormulaR1C1 = "11"
    Range("G5").Select
    ActiveCell.FormulaR1C1 = "12"
    Range("D6").Select
    ActiveCell.FormulaR1C1 = "13"
    Range("E6").Select
    ActiveCell.FormulaR1C1 = "14"
    Range("F6").Select
    ActiveCell.FormulaR1C1 = "15"
    Range("G6").Select
    ActiveCell.FormulaR1C1 = "16"
    Range("A1").Select

    Range("D3:G9,C6,H6").Select
    Range("H6").Activate
    With Selection.Font
        .Name = "Arial Black"
        .Size = 27
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Range("D1:G10,C6,H6").Select
    Range("H6").Activate
    With Selection.Font
        .Color = -13382605
        .TintAndShade = 0
    End With
    
        Range("A1").Select

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

On Error GoTo metka1

If Target.Cells.Value = "/\" Then
Target.Cells.Offset(1, 0).Select

    If Cells(3, 4) = Empty And Cells(3, 5) = Empty And Cells(3, 6) = Empty And Cells(3, 7) = Empty And Cells(4, 4) = Empty And Cells(4, 5) = Empty And Cells(4, 6) = Empty And Cells(4, 7) = Empty And Cells(5, 4) = Empty And Cells(5, 5) = Empty And Cells(5, 6) = Empty And Cells(5, 7) = Empty Then
        For i = 6 To 9
            For j = 4 To 7
                Cells(i - 1, j).Value = Cells(i, j).Value
                Cells(i, j).Value = Empty
            Next j
        Next i
    Exit Sub
    End If

    If Cells(3, 4) = Empty And Cells(3, 5) = Empty And Cells(3, 6) = Empty And Cells(3, 7) = Empty And Cells(4, 4) = Empty And Cells(4, 5) = Empty And Cells(4, 6) = Empty And Cells(4, 7) = Empty And Cells(9, 4) = Empty And Cells(9, 5) = Empty And Cells(9, 6) = Empty And Cells(9, 7) = Empty Then
        For i = 5 To 8
            For j = 4 To 7
                Cells(i - 1, j).Value = Cells(i, j).Value
                Cells(i, j).Value = Empty
            Next j
        Next i
    Exit Sub
    End If

    If Cells(3, 4) = Empty And Cells(3, 5) = Empty And Cells(3, 6) = Empty And Cells(3, 7) = Empty And Cells(8, 4) = Empty And Cells(8, 5) = Empty And Cells(8, 6) = Empty And Cells(8, 7) = Empty And Cells(9, 4) = Empty And Cells(9, 5) = Empty And Cells(9, 6) = Empty And Cells(9, 7) = Empty Then
        For i = 4 To 7
            For j = 4 To 7
                Cells(i - 1, j).Value = Cells(i, j).Value
                Cells(i, j).Value = Empty
            Next j
        Next i
    Exit Sub
    End If

End If

If Target.Cells.Value = "\/" Then
Target.Cells.Offset(1, 0).Select

    If Cells(7, 4) = Empty And Cells(7, 5) = Empty And Cells(7, 6) = Empty And Cells(7, 7) = Empty And Cells(8, 4) = Empty And Cells(8, 5) = Empty And Cells(8, 6) = Empty And Cells(8, 7) = Empty And Cells(9, 4) = Empty And Cells(9, 5) = Empty And Cells(9, 6) = Empty And Cells(9, 7) = Empty Then
        For j = 4 To 7
                Cells(7, j).Value = Cells(6, j)
                Cells(6, j).Value = Empty
        Next j
        For j = 4 To 7
                Cells(6, j).Value = Cells(5, j)
                Cells(5, j).Value = Empty
        Next j
                For j = 4 To 7
                Cells(5, j).Value = Cells(4, j)
                Cells(4, j).Value = Empty
        Next j
                For j = 4 To 7
                Cells(4, j).Value = Cells(3, j)
                Cells(3, j).Value = Empty
        Next j
    Exit Sub
    End If

    If Cells(3, 4) = Empty And Cells(3, 5) = Empty And Cells(3, 6) = Empty And Cells(3, 7) = Empty And Cells(8, 4) = Empty And Cells(8, 5) = Empty And Cells(8, 6) = Empty And Cells(8, 7) = Empty And Cells(9, 4) = Empty And Cells(9, 5) = Empty And Cells(9, 6) = Empty And Cells(9, 7) = Empty Then
        For j = 4 To 7
                Cells(8, j).Value = Cells(7, j)
                Cells(7, j).Value = Empty
        Next j
        For j = 4 To 7
                Cells(7, j).Value = Cells(6, j)
                Cells(6, j).Value = Empty
        Next j
                For j = 4 To 7
                Cells(6, j).Value = Cells(5, j)
                Cells(5, j).Value = Empty
        Next j
                For j = 4 To 7
                Cells(5, j).Value = Cells(4, j)
                Cells(4, j).Value = Empty
        Next j
        
    Exit Sub
    End If
    
    If Cells(3, 4) = Empty And Cells(3, 5) = Empty And Cells(3, 6) = Empty And Cells(3, 7) = Empty And Cells(4, 4) = Empty And Cells(4, 5) = Empty And Cells(4, 6) = Empty And Cells(4, 7) = Empty And Cells(9, 4) = Empty And Cells(9, 5) = Empty And Cells(9, 6) = Empty And Cells(9, 7) = Empty Then
        For j = 4 To 7
                Cells(9, j).Value = Cells(8, j)
                Cells(8, j).Value = Empty
        Next j
        For j = 4 To 7
                Cells(8, j).Value = Cells(7, j)
                Cells(7, j).Value = Empty
        Next j
                For j = 4 To 7
                Cells(7, j).Value = Cells(6, j)
                Cells(6, j).Value = Empty
        Next j
                For j = 4 To 7
                Cells(6, j).Value = Cells(5, j)
                Cells(5, j).Value = Empty
        Next j
        
    Exit Sub
    End If
End If

If Target.Address = "$C$6" Or Target.Address = "$D$6" Or Target.Address = "$E$6" Or Target.Address = "$F$6" Or Target.Address = "$G$6" Or Target.Address = "$H$6" Then
    If Target.Cells.Offset(0, -1) = Empty Then
        Target.Cells.Offset(0, -1).Value = Target.Cells.Value
        Target.Cells.Value = Empty
    End If

    If Target.Cells.Offset(0, 1) = Empty Then
        Target.Cells.Offset(0, 1).Value = Target.Cells.Value
        Target.Cells.Value = Empty
    End If
End If

If Target.Address = "$D$3" Or Target.Address = "$E$3" Or Target.Address = "$F$3" Or Target.Address = "$G$3" Or Target.Address = "$D$4" Or Target.Address = "$E$4" Or Target.Address = "$F$4" Or Target.Address = "$G$4" Or Target.Address = "$D$5" Or Target.Address = "$E$5" Or Target.Address = "$F$5" Or Target.Address = "$G$5" Or Target.Address = "$D$7" Or Target.Address = "$E$7" Or Target.Address = "$F$7" Or Target.Address = "$G$7" Or Target.Address = "$D$8" Or Target.Address = "$E$8" Or Target.Address = "$F$8" Or Target.Address = "$G$8" Or Target.Address = "$D$9" Or Target.Address = "$E$3" Or Target.Address = "$F$9" Or Target.Address = "$G$9" Then
    If Target.Cells.Offset(0, 1) = Empty Then
        Target.Cells.Offset(0, 1).Value = Target.Cells.Value
        Target.Cells.Value = Empty
    End If

    If Target.Cells.Offset(0, -1) = Empty Then
        Target.Cells.Offset(0, -1).Value = Target.Cells.Value
        Target.Cells.Value = Empty
    End If
End If

metka1:

End Sub

Перейти

Макрос копирования файла из одной папки в другую с возможностью выбора папки для сохранения

Михаил И.

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

05.03.2022 11:53:17

Цитата

написал:
Добрый день!Подскажите пожалуйста, как можно доработать вышеуказанный макрос, чтобы выбранный файл раскладывать сразу по нескольким папкам, пути (ссылки) в которые сформированы в табличном виде, дабы каждый раз путь не указывать вручную?

Изменено: Кирилл Л. - 26.02.2022 11:13:34

Если правильно понял задачу, то вот решение:

Код

Function filesCopyFunction()

Dim filesPathsArray() As String
Dim fd As FileDialog
Dim copyToFolder As String
'---------------------------------------------------------------------------
MsgBox "Выберите файлы для копирования"
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
    If .Show = -1 Then
        For Each FilePath In .SelectedItems
            nmbrOfFiles = nmbrOfFiles + 1
        Next
    End If
End With

'счётчик количества файлов для копирования
i = 1
ReDim Preserve filesPathsArray(nmbrOfFiles)
With fd
    For Each FilePath In .SelectedItems
        filesPathsArray(i) = FilePath
        i = i + 1
    Next
End With

Worksheets(1).Activate

'копирование
i = 1
For i = 1 To nmbrOfFiles
For n = 1 To 100 '(здесь 100 это количество строк листа № "1", в которых подряд содержатся пути для копирования)
    Set fs = CreateObject("Scripting.FileSystemObject")
        copyToFolder = Cells(n, 1).Value
        fs.CopyFile (filesPathsArray(i)), copyToFolder
Next n
Next i

MsgBox "Файлы скопированы"

End Function

Перейти

Нестандартное (побайтное) копирование файлов средствами VBA

Михаил И.

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

08.05.2021 15:27:59

'кому-то это нужно...

Код

'-----------------------------------------------------------------
'-----------------------------------------------------------------
'File:      duplex.xls
'Author:    Mikhail I.
'Purpose:   code for the files copying
'               //(for files < 256Mb)
'Revision:  1.0
'-----------------------------------------------------------------
'-----------------------------------------------------------------
Function BinaryDuplicate()
Dim ByteArg() As Byte
Dim ByteNum As String
Dim NewByteNum As String
Dim NewByte As Byte
Dim ByteLen As Integer
Dim NewByteArray() As Byte
Dim FilesPathsArray() As String
Dim FilesSizesArray() As String
Dim timeNow As Date
Dim timeFinish As Date
Dim timeCode As Date
Dim NewFilesPathsArray() As String
Dim OldFilesName() As String
Dim FilePath0 As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
MsgBox "Выберите файлы для копирования"
With fd
    If .Show = -1 Then
        For Each FilePath In .SelectedItems
            NmbrOfFiles = NmbrOfFiles + 1
        Next
    End If
End With
i = 1
ReDim Preserve FilesPathsArray(NmbrOfFiles)
ReDim Preserve OldFilesName(NmbrOfFiles)
With fd
For Each FilePath In .SelectedItems
FilesPathsArray((NmbrOfFiles - (NmbrOfFiles - i))) = FilePath
i = i + 1
Next
i = 1
For Each Filename In .SelectedItems
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(Filename)
OldFilesName((NmbrOfFiles - (NmbrOfFiles - i))) = f.Name
i = i + 1
Next
End With
MsgBox "Выберите папку, куда копировать. (в туже папку копировать нельзя)"
Dim FilePathCopy As String
Dim fd0 As FileDialog
Set fd0 = Application.FileDialog(msoFileDialogFolderPicker)
With fd0
    If .Show = -1 Then
        For Each FolderPath In .SelectedItems
            FilePathCopy = FolderPath
        Next
    End If
End With
Dim SingleFileSize As Variant
Dim FilesSize As Variant
For i0 = 1 To NmbrOfFiles
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FilesPathsArray(i0))
SingleFileSize = f.Size
FilesSize = FilesSize + SingleFileSize
Next i0
MsgBox ("Size:                       " & Left((FilesSize / 1000000), 6) & " Mb" & vbCrLf & _
        "Coding time:  ~  " & Left((((((FilesSize / 1000000) / 60)) * 2)), 6) & " minutes")
Num0 = InputBox("press 0 key")
Num1 = InputBox("press 1 key")
Num2 = InputBox("press 2 key")
Num3 = InputBox("press 3 key")
Num4 = InputBox("press 4 key")
Num5 = InputBox("press 5 key")
Num6 = InputBox("press 6 key")
Num7 = InputBox("press 7 key")
Num8 = InputBox("press 8 key")
Num9 = InputBox("press 9 key")
i0 = 1
timeNow = Time
For n0 = 1 To NmbrOfFiles
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FilesPathsArray(i0))
i00 = 0
fnp = Empty
Do Until fnp = FilesPathsArray(i0)
fnp = Left(FilesPathsArray(i0), i00)
i00 = i00 + 1
Loop
CountSymbolsFullFilePath = i00 - 1
Ext = fs.GetExtensionName(FilesPathsArray(i0))
i00 = 0
extn = Empty
Do Until extn = Ext
extn = Left(Ext, i00)
i00 = i00 + 1
Loop
CountSymbolsExt = i00
CountSymbolsShP = CountSymbolsFullFilePath - CountSymbolsExt - 1
FileNameShortPath = Left(FilesPathsArray(i0), CountSymbolsShP)
Const ForReading = 1, ForWriting = 2, ForAppending = 3
fs.CreateTextFile FileNameShortPath
Set nf = fs.GetFile(FileNameShortPath)
Set ts = nf.OpenAsTextStream(ForWriting, TristateUseDefault)
ts.Write f.Name
ts.Close
Dim TempFileLength As Variant
Dim TempByteArg() As Byte
Dim NewTempByteArray() As Byte
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FileNameShortPath)
TempFileLength = f.Size
Open FileNameShortPath For Binary Access Read Write As #1
ReDim TempByteArg(TempFileLength)
ReDim NewTempByteArray(TempFileLength)
For n = 1 To TempFileLength
Get #1, , TempByteArg(n)
TempByteNum = TempByteArg(n)
TempByteLen = Len(TempByteNum)
If TempByteLen = 1 Then
    If Left(TempByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(TempByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(TempByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(TempByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(TempByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(TempByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(TempByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(TempByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(TempByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(TempByteNum, 1) = Num9 Then NewByteNum = Num9
End If
If TempByteLen = 2 Then
    If Left(TempByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(TempByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(TempByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(TempByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(TempByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(TempByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(TempByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(TempByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(TempByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(TempByteNum, 1) = Num9 Then NewByteNum = Num9
    If Right(TempByteNum, 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right(TempByteNum, 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right(TempByteNum, 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right(TempByteNum, 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right(TempByteNum, 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right(TempByteNum, 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right(TempByteNum, 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right(TempByteNum, 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right(TempByteNum, 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right(TempByteNum, 1) = Num9 Then NewByteNum = NewByteNum + Num9
End If
If TempByteLen = 3 Then
    If Left(TempByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(TempByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(TempByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(TempByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(TempByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(TempByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(TempByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(TempByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(TempByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(TempByteNum, 1) = Num9 Then NewByteNum = Num9
    If Right((Left(TempByteNum, 2)), 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right((Left(TempByteNum, 2)), 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right((Left(TempByteNum, 2)), 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right((Left(TempByteNum, 2)), 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right((Left(TempByteNum, 2)), 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right((Left(TempByteNum, 2)), 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right((Left(TempByteNum, 2)), 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right((Left(TempByteNum, 2)), 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right((Left(TempByteNum, 2)), 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right((Left(TempByteNum, 2)), 1) = Num9 Then NewByteNum = NewByteNum + Num9
    If Right(TempByteNum, 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right(TempByteNum, 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right(TempByteNum, 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right(TempByteNum, 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right(TempByteNum, 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right(TempByteNum, 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right(TempByteNum, 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right(TempByteNum, 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right(TempByteNum, 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right(TempByteNum, 1) = Num9 Then NewByteNum = NewByteNum + Num9
End If
NewTempByteArray(n) = NewByteNum
Next
For n1 = 1 To FileLength
Put #1, n1, NewTempByteArray(n1)
Next
Close #1
Set nf = fs.GetFile(FileNameShortPath)
Set ts = nf.OpenAsTextStream(ForReading, TristateUseDefault)
    NewName = ts.ReadLine
ts.Close
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateTextFile (FilePathCopy & "\" & NewName)
Set fs = CreateObject("Scripting.FileSystemObject")
Set nf = fs.GetFile(FileNameShortPath)
fs.DeleteFile FileNameShortPath, 1
i0 = i0 + 1
Next
i0 = 1
For i1 = 1 To NmbrOfFiles
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FilesPathsArray(i0))
FileLength = f.Size
Open FilesPathsArray(i0) For Binary Access Read Write As #1
ReDim Preserve NewFilesPathsArray(NmbrOfFiles)
NewFilesPathsArray(i0) = FilePathCopy & "\" & OldFilesName(i0)
Open NewFilesPathsArray(i0) For Binary Access Read Write As #2
i0 = i0 + 1
ReDim ByteArg(FileLength)
ReDim NewByteArray(FileLength)
For n = 1 To FileLength
Get #1, , ByteArg(n)
ByteNum = ByteArg(n)
ByteLen = Len(ByteNum)
If ByteLen = 1 Then
    If Left(ByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(ByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(ByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(ByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(ByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(ByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(ByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(ByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(ByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(ByteNum, 1) = Num9 Then NewByteNum = Num9
End If
If ByteLen = 2 Then
    If Left(ByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(ByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(ByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(ByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(ByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(ByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(ByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(ByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(ByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(ByteNum, 1) = Num9 Then NewByteNum = Num9
    If Right(ByteNum, 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right(ByteNum, 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right(ByteNum, 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right(ByteNum, 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right(ByteNum, 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right(ByteNum, 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right(ByteNum, 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right(ByteNum, 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right(ByteNum, 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right(ByteNum, 1) = Num9 Then NewByteNum = NewByteNum + Num9
End If
If ByteLen = 3 Then
    If Left(ByteNum, 1) = Num0 Then NewByteNum = Num0
    If Left(ByteNum, 1) = Num1 Then NewByteNum = Num1
    If Left(ByteNum, 1) = Num2 Then NewByteNum = Num2
    If Left(ByteNum, 1) = Num3 Then NewByteNum = Num3
    If Left(ByteNum, 1) = Num4 Then NewByteNum = Num4
    If Left(ByteNum, 1) = Num5 Then NewByteNum = Num5
    If Left(ByteNum, 1) = Num6 Then NewByteNum = Num6
    If Left(ByteNum, 1) = Num7 Then NewByteNum = Num7
    If Left(ByteNum, 1) = Num8 Then NewByteNum = Num8
    If Left(ByteNum, 1) = Num9 Then NewByteNum = Num9
    If Right((Left(ByteNum, 2)), 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right((Left(ByteNum, 2)), 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right((Left(ByteNum, 2)), 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right((Left(ByteNum, 2)), 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right((Left(ByteNum, 2)), 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right((Left(ByteNum, 2)), 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right((Left(ByteNum, 2)), 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right((Left(ByteNum, 2)), 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right((Left(ByteNum, 2)), 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right((Left(ByteNum, 2)), 1) = Num9 Then NewByteNum = NewByteNum + Num9
    If Right(ByteNum, 1) = Num0 Then NewByteNum = NewByteNum + Num0
    If Right(ByteNum, 1) = Num1 Then NewByteNum = NewByteNum + Num1
    If Right(ByteNum, 1) = Num2 Then NewByteNum = NewByteNum + Num2
    If Right(ByteNum, 1) = Num3 Then NewByteNum = NewByteNum + Num3
    If Right(ByteNum, 1) = Num4 Then NewByteNum = NewByteNum + Num4
    If Right(ByteNum, 1) = Num5 Then NewByteNum = NewByteNum + Num5
    If Right(ByteNum, 1) = Num6 Then NewByteNum = NewByteNum + Num6
    If Right(ByteNum, 1) = Num7 Then NewByteNum = NewByteNum + Num7
    If Right(ByteNum, 1) = Num8 Then NewByteNum = NewByteNum + Num8
    If Right(ByteNum, 1) = Num9 Then NewByteNum = NewByteNum + Num9
End If
NewByteArray(n) = NewByteNum
Next
For n1 = 1 To FileLength
Put #2, n1, NewByteArray(n1)
Next
Close #1
Close #2
Next i1
timeFinish = Time
timeCode = timeFinish - timeNow
Beep
If timeCode > ("00:05:00") Then
For beeping = 1 To 7
Beep
Application.Wait (Now + TimeValue("00:00:01"))
Next beeping
End If
MsgBox ("decoding complited..." & vbCrLf & _
        "" & vbCrLf & _
        "File Size:    " & (FilesSize / 1000000) & " Mb" & vbCrLf & _
        "Start Time:    " & timeNow & "" & vbCrLf & _
        "Finish Time:    " & timeFinish & "" & vbCrLf & _
        "Coding time : " & timeCode)
'Эта программа предоставляется бесплатно. Но вы можете
'помочь проекту отправив любую сумму на этот биткойн адрес:
'14pKtuTeaHJyi4yQeX4T7W3pGphbNrx62p

End Function

Перейти

Переименование файлов Excel в папке

Михаил И. Пользователь Сообщений: 19 Регистрация: 16.08.2018	# 08.04.2020 15:07:47 Это нестандартное переименование. Может из этого кода что-нибудь полезное пригодиться.
	Перейти

Сетевая игра пинг-понг, кодинг пещерного человека

Михаил И. Пользователь Сообщений: 19 Регистрация: 16.08.2018	# 08.04.2020 14:38:02 Всем спасибо за помощь. Вот что получилось. Уверен, что можно было сделать проще. Не судите строго.
	Перейти

Как открывать файлы поочередно по возрастанию имени?

Михаил И. Пользователь Сообщений: 19 Регистрация: 16.08.2018	# 04.04.2020 20:01:50 интересная реализация Изменено: Михаил И. - 08.04.2020 14:33:13
	Перейти

Макрос копирования файла из одной папки в другую с возможностью выбора папки для сохранения

Михаил И.

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

03.04.2020 08:43:04

'Дубликатор. Если нужно скопировать не один файл, а несколько

Код

Function dupe()
Dim filesPathsArray() As String
Dim fd As FileDialog
Dim fName As String
Dim fExt As String
Dim mN As String
'------------------------------------
MsgBox "Выберите файлы для копирования"
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
    If .Show = -1 Then
        For Each FilePath In .SelectedItems
            nmbrOfFiles = nmbrOfFiles + 1
        Next
    End If
End With
i = 1
ReDim Preserve filesPathsArray(nmbrOfFiles)
With fd
    For Each FilePath In .SelectedItems
        filesPathsArray((nmbrOfFiles - (nmbrOfFiles - i))) = FilePath
        i = i + 1
    Next
End With
'--------------------------------------
MsgBox "Выберите куда копировать"
Set fp = Application.FileDialog(msoFileDialogFolderPicker)
With fp
    If .Show = -1 Then
        For Each FolderPath In .SelectedItems
            fName = FolderPath
        Next
    End If
End With
'---------------------------------------
For n = 1 To nmbrOfFiles
    Set fs = CreateObject("Scripting.FileSystemObject")
    mN = fs.GetParentFolderName(filesPathsArray(n))
    If Not fName = mN Then
        Set f = fs.getfile(filesPathsArray(n))
        f.Copy fName
    End If
        
    If fName = mN Then
        Set f = fs.getfile(filesPathsArray(n))
        fExt = fs.GetExtensionName(filesPathsArray(n))
        fName = filesPathsArray(n) + "_копия" + "." + fExt
        f.Copy fName
    End If
Next n
MsgBox "Файлы скопированы"
End Function

Изменено: Михаил И. - 03.04.2020 11:59:09

Перейти

Таблицы Шульте. Тренируем периферическое зрение, кодинг пещерного человека

Михаил И.

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

06.03.2020 23:12:48

Цитата
Юрий М написал: Кто мешает МЕНЯТЬ существующий файл?

Спасибо за совет; не знал что так можно.

Перейти

Чат, кодинг пещерного человека

Михаил И. Пользователь Сообщений: 19 Регистрация: 16.08.2018	# 06.03.2020 22:04:16 всем доброго времени суток! это чат для двоих в локальной сети помогите пожалуйста сделать многопользовательскую версию. Изменено: Михаил И. - 25.03.2020 02:27:58 (исправление ошибок)
	Перейти

Таблицы Шульте. Тренируем периферическое зрение, кодинг пещерного человека

Михаил И.

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

06.03.2020 20:43:02

Цитата
vikttur написал: Задержка в одну секунду - штраф за ошибку? ) Это задержка мешает, сбивает с ритма.

-иначе не видно подмигивание кнопок красным цветом

Цитата
vikttur написал: Закрыли (случайно или нет) форму - как отобразить? Простой пользователь не поймет.

-согласен, это можно дополнить.
просто не знаю как администрация ресурса отнесётся к тому что будет закачано много почти одинаковых файлов. А доделать конечно не сложно.

Перейти

Таблицы Шульте. Тренируем периферическое зрение, кодинг пещерного человека

Михаил И. Пользователь Сообщений: 19 Регистрация: 16.08.2018	# 06.03.2020 14:43:23 кое-что доработал, исправил ошибки. вот новая версия: Изменено: Михаил И. - 06.03.2020 23:10:40
	Перейти

Таблицы Шульте. Тренируем периферическое зрение, кодинг пещерного человека

Михаил И. Пользователь Сообщений: 19 Регистрация: 16.08.2018	# 01.03.2020 15:38:17 Развивающие таблицы Шульте
	Перейти

Сетевая игра пинг-понг, кодинг пещерного человека

Михаил И. Пользователь Сообщений: 19 Регистрация: 16.08.2018	# 12.02.2020 13:53:54 помогите пожалуйста довести до ума игруху: не получается привести в движение шарик. пробовал через application.wait и через application.ontime - не работает
	Перейти

интернет радиоприёмник

Михаил И. Пользователь Сообщений: 19 Регистрация: 16.08.2018	# 11.10.2019 03:51:48 проигрывает интернет радиостанции из списка в случайном порядке
	Перейти

Игра "ход конём"

Михаил И. Пользователь Сообщений: 19 Регистрация: 16.08.2018	# 12.07.2019 22:56:28 Это же не коммерческая версия, а просто так, для развлечения... Зато код не слишком длинный.
	Перейти

Игра "ход конём"

Михаил И.

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

12.07.2019 17:43:18

Код

'Program Name:      horse
'Purpose:           Entertainment puzzle game
'Author:            
'Date:              01.12.2009
'Version:           ...
'File Size:         ...

Option Explicit

Dim n As Integer
Dim x As Integer
Dim i As Boolean
Dim TimeStart As Date
Dim timeFinish As Date
Dim TimeSolve As Date

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Cells.Select
    Selection.ClearContents
Rows("3:12").Select
    Selection.RowHeight = 30
Columns("C:L").Select
    Selection.ColumnWidth = 5
Range("C3:L12").Select
    With Selection
    .Borders.LineStyle = xlContinuous
    .Borders(xlEdgeLeft).Weight = xlMedium
    .Borders(xlEdgeTop).Weight = xlMedium
    .Borders(xlEdgeBottom).Weight = xlMedium
    .Borders(xlEdgeRight).Weight = xlMedium
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Name = "Calibri"
    .Font.Size = 17
End With
Range("O1").Select
Cells(1, 15).Value = "ЗАНОВО"
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    End With
    
    Application.ScreenUpdating = True
    TimeStart = TimeValue(Now)
    x = 1
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Target.Cells.Value = Empty
n = n - 1
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Address = "$O$1" Then
    Range("C3:L13").Select
    Selection.ClearContents
    TimeStart = TimeValue(Now)
    i = True
    n = 0
End If

If Not Target.Address = "$O$1" Then
    If x = 1 Then
        n = n + 1
        Target.Cells.Value = n
        x = 2
        Exit Sub
    End If
End If

If Not Target.Address = "$O$1" Then
    If x = 2 Then
        If ActiveCell.Offset(2, 1).Value = n Or ActiveCell.Offset(2, -1).Value = n Or ActiveCell.Offset(1, -2).Value = n Or ActiveCell.Offset(-1, -2).Value = n Or ActiveCell.Offset(-2, -1).Value = n Or ActiveCell.Offset(-2, 1).Value = n Or ActiveCell.Offset(-1, 2).Value = n Or ActiveCell.Offset(1, 2).Value = n Then
            n = n + 1
            Target.Cells.Value = n
            Else: MsgBox "Конь ходит буквой 'Г'"
        End If
    End If
End If

If n = 100 And i = True Then
timeFinish = TimeValue(Now)
TimeSolve = timeFinish - TimeStart
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "Отлично!" & vbCrLf & _
        "Время сборки: " & TimeSolve
i = False
n = 0
End If


End Sub

Перейти

Игра пятнашки с перемешиванием ячеек

Михаил И.

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

16.02.2019 14:07:29

Крутая реализация. Проще и быстрее, - согласен... Но перемешивание осуществляется рандомно и расклад сходится не всегда. А хотелось бы, чтобы сходился. Я читал где-то что нужно, чтобы количество итераций было чётным, но полностью не разобрался. Вот к примеру на сайте https://cepia.ru/pyatnashki реализованы пятнашки с очень быстрым перемешиванием и всегда сходящимся раскладом.

Перейти

Как программно добавить форму, Может кому-нибудь пригодится

Михаил И.

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

13.02.2019 23:53:32

Программно добавить форму можно следующим способом: поставить галочку в меню "Разработчик-Безопасность макросов-Доверять доступ к объектной модели VBA" и после этого запустить нижеследующую функцию:

Код
Function AddForm() ActiveWorkbook.VBProject.VBComponents.Add (3) End Function

Перейти

Игра пятнашки с перемешиванием ячеек

Михаил И.

Пользователь

Сообщений: 19 Регистрация: 16.08.2018

04.02.2019 20:42:04

Код

'Для большей безопастности привожу пост кода
'Для запуска: 1. скопируйте этот код в код любого листа книги Эксэль 2. Активируйте какой-нибудь другой лист 3. Активируйте исходный лист 4. Пазл готов!

'Program Name:      fithteen
'Purpose:           Entertainment puzzle game
'Author:            Михаил И.
'Date:              01.12.2009
'Version:           ...
'File Size:         ...

Dim x As Boolean
Dim TimeStart As Date
Dim timeFinish As Date
Dim TimeSolve As Date

Private Sub Worksheet_Activate()

Application.ScreenUpdating = False

    Rows("1:6").Select
    Selection.RowHeight = 45
    Range("B2:E5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("A1:A6,B1:F1,F2:F6,B6:E6").Select
    Range("E6").Activate
    With Selection.Interior
        .ColorIndex = 10
        .Pattern = xlSolid
    End With
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("F3").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("F5").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("F6").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("E6").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("D6").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("C6").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B6").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "o"
    Range("B2:E5").Select
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 36
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    
    Range("B2:E5").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:F1,A2:A6,B6:F6,F2:F5").Select
    Range("F5").Activate
    Selection.Font.ColorIndex = 10
    Range("B2:E5").Select
    Selection.Font.ColorIndex = 50
    
        Range("G1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15773696
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveCell.FormulaR1C1 = "Перемеш"
    Range("G1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

Application.ScreenUpdating = True

End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

On Error GoTo metka

If Target.Address = "$B$2" Or Target.Address = "$C$2" Or Target.Address = "$D$2" Or Target.Address = "$E$2" Or Target.Address = "$B$3" Or Target.Address = "$C$3" Or Target.Address = "$D$3" Or Target.Address = "$E$3" Or Target.Address = "$B$4" Or Target.Address = "$C$4" Or Target.Address = "$D$4" Or Target.Address = "$E$4" Or Target.Address = "$B$5" Or Target.Address = "$C$5" Or Target.Address = "$D$5" Or Target.Address = "$E$5" Then

    If Target.Cells.Offset(-1, 0).Value = Empty Then
        Target.Cells.Offset(-1, 0).Value = ActiveCell.Value
        ActiveCell.Value = Empty
            Else
            If Target.Cells.Offset(0, 1).Value = Empty Then
            Target.Cells.Offset(0, 1).Value = ActiveCell.Value
            ActiveCell.Value = Empty
                Else
                If Target.Cells.Offset(1, 0).Value = Empty Then
                Target.Cells.Offset(1, 0).Value = ActiveCell.Value
                ActiveCell.Value = Empty
                    Else
                    If Target.Cells.Offset(0, -1).Value = Empty Then
                    Target.Cells.Offset(0, -1).Value = ActiveCell.Value
                    ActiveCell.Value = Empty
                        Else
                    End If
                End If
            End If
    End If
End If
If Cells(2, 2).Value = 1 And Cells(2, 3).Value = 2 And Cells(2, 4).Value = 3 And Cells(2, 5).Value = 4 And Cells(3, 2).Value = 5 And Cells(3, 3).Value = 6 And Cells(3, 4).Value = 7 And Cells(3, 5).Value = 8 And Cells(4, 2).Value = 9 And Cells(4, 3).Value = 10 And Cells(4, 4).Value = 11 And Cells(4, 5).Value = 12 And Cells(5, 2).Value = 13 And Cells(5, 3).Value = 14 And Cells(5, 4).Value = 15 And Cells(5, 5).Value = Empty And x = True Then
timeFinish = TimeValue(Now)
TimeSolve = timeFinish - TimeStart
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "Good!" & vbCrLf & _
        "Время сборки: " & TimeSolve
x = False
End If
If Cells(2, 2).Value = Empty And Cells(2, 3).Value = 1 And Cells(2, 4).Value = 2 And Cells(2, 5).Value = 3 And Cells(3, 2).Value = 4 And Cells(3, 3).Value = 5 And Cells(3, 4).Value = 6 And Cells(3, 5).Value = 7 And Cells(4, 2).Value = 8 And Cells(4, 3).Value = 9 And Cells(4, 4).Value = 10 And Cells(4, 5).Value = 11 And Cells(5, 2).Value = 12 And Cells(5, 3).Value = 13 And Cells(5, 4).Value = 14 And Cells(5, 5).Value = 15 Then
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "так тоже можно" & vbCrLf & _
        "Время сборки: " & TimeSolve
x = False
End If
If Cells(2, 2).Value = Empty And Cells(2, 3).Value = 15 And Cells(2, 4).Value = 14 And Cells(2, 5).Value = 13 And Cells(3, 2).Value = 12 And Cells(3, 3).Value = 11 And Cells(3, 4).Value = 10 And Cells(3, 5).Value = 9 And Cells(4, 2).Value = 8 And Cells(4, 3).Value = 7 And Cells(4, 4).Value = 6 And Cells(4, 5).Value = 5 And Cells(5, 2).Value = 4 And Cells(5, 3).Value = 3 And Cells(5, 4).Value = 2 And Cells(5, 5).Value = 1 Then
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "так тоже можно" & vbCrLf & _
        "Время сборки: " & TimeSolve
x = False
End If
If Cells(2, 2).Value = 1 And Cells(2, 3).Value = 5 And Cells(2, 4).Value = 9 And Cells(2, 5).Value = 13 And Cells(3, 2).Value = 2 And Cells(3, 3).Value = 6 And Cells(3, 4).Value = 10 And Cells(3, 5).Value = 14 And Cells(4, 2).Value = 3 And Cells(4, 3).Value = 7 And Cells(4, 4).Value = 11 And Cells(4, 5).Value = 15 And Cells(5, 2).Value = 4 And Cells(5, 3).Value = 8 And Cells(5, 4).Value = 12 And Cells(5, 5).Value = Empty Then
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "так тоже можно" & vbCrLf & _
        "Время сборки: " & TimeSolve
x = False
End If
If Cells(2, 2).Value = Empty And Cells(2, 3).Value = 12 And Cells(2, 4).Value = 8 And Cells(2, 5).Value = 4 And Cells(3, 2).Value = 15 And Cells(3, 3).Value = 11 And Cells(3, 4).Value = 7 And Cells(3, 5).Value = 3 And Cells(4, 2).Value = 14 And Cells(4, 3).Value = 10 And Cells(4, 4).Value = 6 And Cells(4, 5).Value = 2 And Cells(5, 2).Value = 13 And Cells(5, 3).Value = 9 And Cells(5, 4).Value = 5 And Cells(5, 5).Value = 1 Then
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "так тоже можно" & vbCrLf & _
        "Время сборки: " & TimeSolve
x = False
End If

If Target.Address = "$G$1" Then
    MsgBox "При этом перемешивании расклад сходится, но перемешивается очень долго." & vbCrLf & _
        "Было бы здорово если бы помогли найти формулу для этой функции"
    Call fill_the_table
    TimeStart = TimeValue(Now)
End If

metka:

End Sub

Function fill_the_table()

Application.ScreenUpdating = False

n = 1
For i = 2 To 5
    For j = 2 To 5
        Cells(i, j).Value = n
        n = n + 1
    Next j
Next i
Cells(5, 5).Value = Empty
x = True

n = 1
For n = 1 To 2018

        If Cells(2, 2).Value = Empty Then
step1:
            i = WorksheetFunction.RandBetween(2, 3)
            j = WorksheetFunction.RandBetween(2, 3)
            If (i = 2 And j = 2) Or (i = 3 And j = 3) Then GoTo step1
            Cells(2, 2).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
                
        If Cells(2, 3).Value = Empty Then
step2:
            i = WorksheetFunction.RandBetween(2, 3)
            j = WorksheetFunction.RandBetween(2, 4)
            If (i = 2 And j = 3) Or (i = 3 And j = 2) Or (i = 3 And j = 4) Then GoTo step2
            Cells(2, 3).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(2, 4).Value = Empty Then
step3:
            i = WorksheetFunction.RandBetween(2, 3)
            j = WorksheetFunction.RandBetween(3, 5)
            If (i = 2 And j = 4) Or (i = 3 And j = 3) Or (i = 3 And j = 5) Then GoTo step3
            Cells(2, 4).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(2, 5).Value = Empty Then
step4:
            i = WorksheetFunction.RandBetween(2, 3)
            j = WorksheetFunction.RandBetween(4, 5)
            If (i = 2 And j = 5) Or (i = 3 And j = 4) Then GoTo step4
            Cells(2, 5).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(3, 2).Value = Empty Then
step5:
            i = WorksheetFunction.RandBetween(2, 4)
            j = WorksheetFunction.RandBetween(2, 3)
            If (i = 3 And j = 2) Or (i = 2 And j = 3) Or (i = 4 And j = 3) Then GoTo step5
            Cells(3, 2).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(3, 3).Value = Empty Then
step6:
            i = WorksheetFunction.RandBetween(2, 4)
            j = WorksheetFunction.RandBetween(2, 4)
            If (i = 3 And j = 3) Or (i = 2 And j = 2) Or (i = 2 And j = 4) Or (i = 4 And j = 4) Or (i = 4 And j = 2) Then GoTo step6
            Cells(3, 3).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(3, 4).Value = Empty Then
step7:
            i = WorksheetFunction.RandBetween(2, 4)
            j = WorksheetFunction.RandBetween(3, 5)
            If (i = 3 And j = 4) Or (i = 2 And j = 3) Or (i = 2 And j = 5) Or (i = 4 And j = 5) Or (i = 4 And j = 3) Then GoTo step7
            Cells(3, 4).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(3, 5).Value = Empty Then
step8:
            i = WorksheetFunction.RandBetween(2, 4)
            j = WorksheetFunction.RandBetween(4, 5)
            If (i = 3 And j = 5) Or (i = 2 And j = 4) Or (i = 4 And j = 4) Then GoTo step8
            Cells(3, 5).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(4, 2).Value = Empty Then
step9:
            i = WorksheetFunction.RandBetween(3, 5)
            j = WorksheetFunction.RandBetween(2, 3)
            If (i = 4 And j = 2) Or (i = 3 And j = 3) Or (i = 5 And j = 3) Then GoTo step9
            Cells(4, 2).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(4, 3).Value = Empty Then
step10:
            i = WorksheetFunction.RandBetween(3, 5)
            j = WorksheetFunction.RandBetween(2, 3)
            If (i = 4 And j = 3) Or (i = 3 And j = 2) Or (i = 3 And j = 4) Or (i = 5 And j = 4) Or (i = 5 And j = 2) Then GoTo step10
            Cells(4, 3).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(4, 4).Value = Empty Then
step11:
            i = WorksheetFunction.RandBetween(3, 5)
            j = WorksheetFunction.RandBetween(3, 5)
            If (i = 4 And j = 4) Or (i = 3 And j = 3) Or (i = 3 And j = 5) Or (i = 5 And j = 5) Or (i = 5 And j = 3) Then GoTo step11
            Cells(4, 4).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(4, 5).Value = Empty Then
step12:
            i = WorksheetFunction.RandBetween(3, 5)
            j = WorksheetFunction.RandBetween(4, 5)
            If (i = 4 And j = 5) Or (i = 3 And j = 4) Or (i = 5 And j = 4) Then GoTo step12
            Cells(4, 5).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(5, 2).Value = Empty Then
step13:
            i = WorksheetFunction.RandBetween(4, 5)
            j = WorksheetFunction.RandBetween(2, 3)
            If (i = 5 And j = 2) Or (i = 4 And j = 3) Then GoTo step13
            Cells(5, 2).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(5, 3).Value = Empty Then
step14:
            i = WorksheetFunction.RandBetween(4, 5)
            j = WorksheetFunction.RandBetween(2, 4)
            If (i = 5 And j = 3) Or (i = 4 And j = 2) Or (i = 4 And j = 4) Then GoTo step14
            Cells(5, 3).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(5, 4).Value = Empty Then
step15:
            i = WorksheetFunction.RandBetween(4, 5)
            j = WorksheetFunction.RandBetween(3, 5)
            If (i = 5 And j = 4) Or (i = 4 And j = 3) Or (i = 4 And j = 5) Then GoTo step15
            Cells(5, 4).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
        If Cells(5, 5).Value = Empty Then
step16:
            i = WorksheetFunction.RandBetween(4, 5)
            j = WorksheetFunction.RandBetween(4, 5)
            If (i = 5 And j = 5) Or (i = 4 And j = 4) Then GoTo step16
            Cells(5, 5).Value = Cells(i, j).Value
            Cells(i, j).Value = Empty
        End If
        
Next n

Application.ScreenUpdating = True

End Function

Изменено: Михаил И. - 04.02.2019 23:29:24

Перейти