Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.88/831: Рейтинг темы: голосов - 831, средняя оценка - 4.88
аналитика
здесь больше нет...
3353 / 1665 / 184
Регистрация: 03.02.2010
Сообщений: 1,219
1

Авторские программы, библиотеки, надстройки и шаблоны

12.02.2010, 17:42. Просмотров 150493. Ответов 187
Метки нет (Все метки)

 Комментарий модератора 
Коллектив модераторов раздела оставляет за собой право использовать данный пост аналитики для размещения и обновления оглавления темы.

Оглавление
- по тематике:

Утилиты


Инструменты программиста

Графические редакторы



Защита программного кода

Офисные операции

Веб-сервис


Игры




- по автору:
A-Z





Конец оглавления

Оригинальное сообщение от аналитики:

Надстройка для VBE "IndenterVBA" - позволяет редактировать стиль оформления программного кода.
27
Вложения
Тип файла: rar IndenterVBA.rar (253.1 Кб, 1599 просмотров)
QA
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
12.02.2010, 17:42
Ответы с готовыми решениями:

Программы на 1С и авторские права
На форуме много сильных программистов, полагаю, что кто-то пишет и отдельные программы. Интересует...

Поменять авторские права в описании программы
Народ подскажите как поменять авторские права в описании программы, срочно надо. Пож-та

Полезные коды и авторские программы на Lisp
Расскажите, пожалуйста, что на лиспе пишите? вкратце, хотя бы. Очень интересно. Понятно, что...

Где хранятся шаблоны во время выполнения программы?
Где хранятся шаблоны во время выполнения программы? и если у меня если: template<typename T>...

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

187
bedvit
625 / 186 / 19
Регистрация: 20.05.2016
Сообщений: 745
Записей в блоге: 11
13.12.2018, 19:17 161
Раз уж зашла тема о сортировке, поделюсь своим решением. А коллеги оценят, стоило ли это определенных усилий.
Решение для Excel 32bit и для Excel 64bit. Приведенные ниже тесты для Excel2016 64 bit.
Aleks777, ваше решение сортирует 2 млн. строк за 12,38 сек., код:
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Option Explicit
Const testSize = 2000000
Dim arr(testSize)
 
Sub test()
Dim i&, t
For i = 0 To testSize
  arr(i) = Format$(Int(Rnd * testSize), "0000000")
Next
 
t = Timer
   Call QSort(arr(), LBound(arr), UBound(arr))
Debug.Print Timer - t
 
End Sub
 
Sub QSort(ByRef arr As Variant, ByVal iLbound As Long, iUbound As Long)
    Dim iL As Long, iU As Long
    Dim iVal As Long, iSwap As Long
    iL = iLbound:    iU = iUbound
    iVal = arr((iLbound + iUbound) \ 2)
    Do While iL <= iU
       Do While arr(iL) < iVal And iL < iUbound
          iL = iL + 1
       Loop
       Do While iVal < arr(iU) And iU > iLbound
          iU = iU - 1
       Loop
       If iL <= iU Then
          iSwap = arr(iL)
          arr(iL) = arr(iU)
          arr(iU) = iSwap
          iL = iL + 1
          iU = iU - 1
       End If
    Loop
     
    If iLbound < iU Then
        Call QSort(arr, iLbound, iU)
    End If
    If iL < iUbound Then
        Call QSort(arr, iL, iUbound)
    End If
End Sub

Самый быстрый код сортировки на VBA,который мне удалось найти, сортирует 2 млн. строк за 6,8 сек. код:
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Option Explicit
Const testSize = 2000000
Dim arr(testSize), x$, y$
 
Sub test()
Dim i&
For i = 0 To testSize
  arr(i) = Format$(Int(Rnd * testSize), "0000000")
Next
 
Dim t#
t = Timer
QuickSort 0, testSize
Debug.Print Timer - t
 
End Sub
 
Sub QuickSort(ByVal L As Long, ByVal U As Long)
Dim i As Long, J As Long
i = L: J = U: x = arr((L + U) \ 2)
Do
  While arr(i) < x: i = i + 1: Wend: While x < arr(J): J = J - 1: Wend 'по возрастанию
'  While A(I) > X: I = I + 1: Wend: While X > A(J): J = J - 1: Wend 'по убыванию
  If i <= J Then
    y = arr(i): arr(i) = arr(J): arr(J) = y:    i = i + 1: J = J - 1
  End If
Loop Until i > J
If L < J Then QuickSort L, J
If i < U Then QuickSort i, U
End Sub

Мое решение - Простая сорт. 1х массива, по возрастанию (по умолч.): 0,21875 сек.
Быстрее в 30-35 раз!
Если все еще интересно, небольшое описание:
Это метод класса в .xll - библиотеке (открываем или устанавливаем как обычную надстройку). Подключается и используется в VBA одной строкой, элементарно через CreateObject("BedvitCOM.VBA").
Функционал:
1.Сортировка одномерных и двухмерных массивов + любой размерности по индексам какого либо измерения.
2.Удаление дубликатов в одномерных массивах
3.Вывод по одномерному и двухмерному массивам индексов по строкам или столбцам.
4.Сортировка по столбцам, строкам, целому массиву с выводом строки/столбцы, столбцы/строки.
5.Сортировка по 3 ключам (столбцам, строкам)
6.Размерность массива может начинаться с 0,1,2... и т.д. (любого положительного числа, вывод индексов в такой же размерности)
7.Обработка NULL - строк (перемещение на последние позиции)
8.Использованы параллельные алгоритмы сортировки.
(стандартные С++ библиотеки "PPL", костыли не прикручивал)

Полное описание и сама библиотека/надстройка в моем блоге.
Проект уже закончен, возможны небольшие дополнения в функционале, оптимизация. Пользуйтесь, по замечаниям и предложениям прошу в блог (ссылка выше).
2
Остап Бонд
1168 / 639 / 297
Регистрация: 17.08.2017
Сообщений: 1,633
13.12.2018, 20:48 162
Цитата Сообщение от Aleks777 Посмотреть сообщение
потеряйся, не надо так писать
А как надо?
Ведь это Вы сумели в два раза затупить замедлить реализацию существующего (как минимум 6 лет(по факту-гораздо больше)) на VBA алгоритма.
0
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
14.12.2018, 23:10 163
Aleks777, сделай что-то еще оригинальное, это закрепленная тема, сейчас ее никто не курирует как вижу, иначе бы давно бы снесли твои посты, или создай тему на VBA кто не дает
0
Catstail
Модератор
25222 / 12884 / 2386
Регистрация: 12.02.2012
Сообщений: 21,016
17.12.2018, 11:14 164
Простенький клеточный автомат - "Жизнь" (на зацикленном по обеим координатам поле 26*26):
3
Миниатюры
Авторские программы, библиотеки, надстройки и шаблоны  
Вложения
Тип файла: zip VBA-CG.zip (17.1 Кб, 20 просмотров)
17.12.2018, 11:14
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
03.01.2019, 23:02 165
Реализация подсказок в текстовых полях и автоматическая обработка форматов

Подсказки реализуются на подобии свойства CueBanner у некоторых текстовых контролов
Так-же есть возможность следить за фокусом всех объектов на форме


Авторские программы, библиотеки, надстройки и шаблоны


Автор вопроса: Otradnoe_4D
Топик: Авто форматирование TextBox

Новый текст кода для формы с подробными комментариями:
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
Option Explicit
'
'автор: fever brain
'
Dim WithEvents tx As MSForms.TextBox, WithEvents cb As MSForms.CommandButton
Dim colBanner As New Collection
 
 
 
 Private Sub cb_Click()
    'Кнопки cb1, cb2
    Dim i&, s$
    Select Case Mid$(cb.Name, 3)
    Case 1 'Удаление текстовых полей
        For i = 1 To 4
            Me.Controls("tx" & i).Text = ""
        Next
        Call CheckCueBanner
    Case 2 'Запись в буфер обмена (серые поля не пишутся)
        With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            For i = 1 To 4
                With Me.Controls("tx" & i)
                    s = s & IIf(.ForeColor = vbButtonShadow, "", vbLf & .Text)
                End With
            Next
            .SetText Mid$(s, 1 + Abs(Left(s, 1) = vbLf))
            .PutInClipboard
        End With
    End Select
    
End Sub
 
 
Private Sub ExitFocus(ByVal prevFocus$, nextFocus$)
    '
    'Здесь можно написать код при выходе из фокуса объекта наподобии события Validate (vb6)
    '
    With Controls(prevFocus)
        Select Case prevFocus
        Case "tx1", "tx2", "tx3"
            'Пример замены заглавных букв в соотв. поле Фамилия, Имя и тд
            '
            .Text = UCase(Left$(.Text, 1)) & LCase(Mid$(.Text, 2))
        Case "tx4"
            'Пример обработки поля tx4 с датой, если дата неправильная то возврат фокуса
            '
            If nextFocus = "cb1" Then Exit Sub 'Кнопка очистки проигнорируется
            If .Text <> "" And Not IsDate(.Text) Then
                MsgBox "неверный формат даты (дата месяц год)", 48
                .SetFocus 'возврат фокуса
            ElseIf .Text <> "" Then
                .Text = Format(.Text, "dd.mm.yyyy")
            End If
        End Select
    End With
End Sub
 
 
Private Sub CheckCueBanner(Optional ByVal ActiveControlName As String)
    '
    'Здесь просматриваются все контролы, и выставляются подсказки серым цветом в текстовые поля
    'имеющие названия tx#...
    '
    Dim v
    For Each v In Controls
        With v
            If .Name Like "tx#" Then
                If ActiveControlName <> .Name And .Text = "" Then
                    .Text = colBanner(.Name)
                    .ForeColor = vbButtonShadow
                ElseIf ActiveControlName = .Name And .ForeColor = vbButtonShadow Then
                    .ForeColor = vbWindowText
                    .Text = ""
                End If
            End If
        End With
    Next
End Sub
 
Private Sub MainLoop()
    '
    'Здесь основной цикл, который монитолит изменения в активности контролов
    'И если контрол изменился производятся новые ссылки на объекты TextBox, Combobox
    'с псевдонимами tx# и cb# и выполняет дополнительные связанные с этим процедуры
    '
    Dim prevFocus$, nextFocus$
'    On Error Resume Next
    Do
        prevFocus = ActiveControl.Name
        DoEvents
        nextFocus = ActiveControl.Name
 
        If prevFocus <> nextFocus Then
            If nextFocus Like "tx#" Then Set tx = ActiveControl
            If nextFocus Like "cb#" Then Set cb = ActiveControl
        
            ExitFocus prevFocus, nextFocus 'Потеря фокуса наподобии LostFocus
            CheckCueBanner nextFocus 'Проверка и вставка подсказок в текстовые поля
        End If
    Loop
End Sub
 
 
Private Sub UserForm_Activate()
    Call MainLoop
End Sub
 
Private Sub UserForm_Initialize()
    '
    'Загрузка динамических объектов на форму
    '
    Const r = 7 'Минимальный размер сетки
    Dim v, i&, j&
 
    For i = 1 To 4
        With Controls.Add("forms.textbox.1", "tx" & i, 1)
            .Move r, j * (.Height + r) + r, .Width * 3, .Height
            colBanner.Add Choose(i, "Фамилия", "Имя", "Отчество", "Дата рождения"), "tx" & i
        End With
        j = j + 1
    Next
    For i = 1 To 2
        With Controls.Add("forms.commandbutton.1", "cb" & i, 1)
            .Move (i - 1) * (.Width + r) + r, j * .Height + r * 2, .Width, .Height
            .Caption = Choose(i, "Очистить все", "Копировать")
        End With
    Next
    
    
    Set cb = Controls("cb2"): cb.SetFocus
    
    With Me
        .Move .Left, .Top, r * 35, r * 25
    End With
 
    Call CheckCueBanner
End Sub
 
Private Sub UserForm_Terminate()
    End
End Sub
2
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
01.02.2019, 06:24 166
Проверка на валидность СНИЛС и ИНН по контрольным суммам



Топик: Проверка СНИЛС, ИНН на выходе из текстбокса
1
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
02.02.2019, 18:59 167
Теперь с возможностью генерировать эти данные:



топик: Проверка СНИЛС, ИНН на выходе из текстбокса

Не по теме:


Хотел в один топик поместить не получилось...
все это на одну тему. можно объеденить.

0
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
15.02.2019, 04:47 168
Заполнение макросом таблицы случайными данными

Макрос который заполнит указанный квадрат (например таблицу) Вашими данными


Стартовая страница:



Результат:



Топик: >> Заполнение макросом таблицы случайными данными
1
bedvit
625 / 186 / 19
Регистрация: 20.05.2016
Сообщений: 745
Записей в блоге: 11
15.03.2019, 23:50 169
Благодаря Catstail, и поста 164 родилось следующее:
Клеточные автоматы ч.1 - Conway's Game of Life in Excel
и
Клеточные автоматы ч.2 - Conway's Game of Life (С++ WinAPI)
2
Миниатюры
Авторские программы, библиотеки, надстройки и шаблоны   Авторские программы, библиотеки, надстройки и шаблоны  
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
01.04.2019, 12:11 170
Игра-головоломка 15

программный код;
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
Option Explicit
'Игра 15
'Автор: fever brain (Cyberforum.ru)
'
Const Grid = 4 'Число клеток в строке - Здесь можно установить значение от 2 до 6 (для игры 15 это 4)
Const minCol = 2, minRow = 2 'Первая клетка
Const maxCol = minCol + (Grid - 1), maxRow = minRow + (3 * (Grid - 1)) 'Последняя клетка
Const maxGrid = Grid * Grid - 1 'Максимальное число клеток
Const Busy = 6 'Цвет занятых клеток
Const Free = 5 'Цвет пустой клетки
Dim Total As Long
 
Private Sub CheckResult()
    Dim i&, j&, ch&
    For i = minRow To maxRow Step 3
        For j = minCol To maxCol
        ch = ch + 1
        If Cells(i, j).Value <> ch Then Exit Sub
        If ch = maxGrid Then Exit For
    Next j, i
    If MsgBox("Победа !" & vbLf & "Начать заново ?", 68) = vbYes Then NewPlay
    
End Sub
 
 
 
Private Sub Counter(Optional ByVal ResetCoun As Boolean)
    If ResetCoun Then
        Total = 0
    Else
        Total = Total + 1
    End If
    [h6] = "Число ходов: " & Total
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim v, r As Range
    If Target.Count = 3 And Target.Interior.ColorIndex = Busy Then
        'Если нажата занятая клетка
        '
        On Error Resume Next
        For Each v In Array(Array(-3, 0), Array(0, 1), Array(3, 0), Array(0, -1))
            'проверка соседних клеток (куда можно переместиться)
            '
            Set r = Nothing: Set r = Cells(Target.Row + v(0), Target.Column + v(1))
            If Not r Is Nothing Then
                If r.Interior.ColorIndex = Free Then
                    Set r = Range(r, Cells(r.Row + 2, r.Column))
                    r.Interior.ColorIndex = Busy: r.Value = Target.Value
                    Target.Value = "": Target.Interior.ColorIndex = Free
                    Call Counter 'Счетчик ходов
                    Call CheckResult  'Проверка на победу :)
                End If
            End If
        Next
    End If
 
End Sub
 
Private Sub reset()
    'Сброс форматирования
    '
    [a1].Copy
    With Columns("B:Z")
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False: Application.CutCopyMode = False
        .ClearContents
    End With
End Sub
 
Sub NewPlay()
    'Новая игра
    '
    Dim i&, j&, k$, cl As New Collection
    Application.ScreenUpdating = False
    Call reset
    Randomize
    On Error Resume Next
    For i = minRow To maxRow Step 3
        For j = minCol To maxCol
            With Range(Cells(i, j), Cells(i + 2, j))
                .Merge
                If cl.Count < maxGrid Then
                    Do
                        Err.Clear: k = Fix(Rnd * maxGrid) + 1: cl.Add 0, k
                    Loop While Err > 0
                    .Value = k
                Else
                    .Value = ""
                End If
                
            End With
        Next
    Next
    
    With Range(Cells(minRow, minCol), Cells(maxRow + 2, maxCol))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        With .Font
            .Name = "Cooper Black"
            .Size = 22
        End With
 
        For i = 7 To 12
            With .Borders(i)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        Next
        .Interior.ColorIndex = Busy
    End With
    With Range(Cells(maxRow, maxCol), Cells(maxRow + 2, maxCol))
    
        .Interior.ColorIndex = Free
        .Select
    End With
    Counter True
    Application.ScreenUpdating = True
End Sub
 
 
Private Sub CommandButton1_Click()
    Call NewPlay
End Sub


Обсудить можно здесь






Лист: Игра-15.xls
3
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
02.04.2019, 18:27 171
Новая ссылка: Игра-15_2.xls

дело в том, что можно не собрать последовательность, если изначальный расклад 1-2-3... был в нем вместо последних цифр 14-15 стал 15-14 а затем тщательно перемешать передвижением. Таким образом топология нарушиться.
В данном коде сначала все ставится все по местам и рандомным передвижением, в направлении пустой клетки перемешивается весь массив.примерно 1000 раз


Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
Option Explicit
'Игра 15
'Автор: fever brain (Cyberforum.ru)
'
Const Grid = 4 'Число клеток в строке - Здесь можно установить значение от 2 до 6 (для игры 15 это 4)
Const minCol = 2, minRow = 2 'Первая клетка
Const maxCol = minCol + (Grid - 1), maxRow = minRow + (3 * (Grid - 1)) 'Последняя клетка
Const maxGrid = Grid * Grid - 1 'Максимальное число клеток
Const Busy = 6 'Цвет занятых клеток
Const Free = 5 'Цвет пустой клетки
Dim Total As Long
 
 
Sub CreateArr(arr())
    Dim i&, j&, n&, x&, y&, xx&, yy&, g1&, v
    ReDim arr(Grid - 1, Grid - 1)
    g1 = Grid - 1: x = g1: y = g1
    
     'Сначало все цифры ставим по порядку
    For i = 0 To g1: For j = 0 To g1
        n = (n + 1) Mod (maxGrid + 1): arr(i, j) = n
    Next j, i
    
    'Цикл рандомных передвижений пустой клетки тоесть в массиве это ноль
    Randomize
    Do
        v = Choose(Fix(Rnd * 4) + 1, Array(-1, 0), Array(0, 1), Array(1, 0), Array(0, -1)) 'Рандомный выбор направления в массиве
        xx = x + v(0): yy = y + v(1)
        
        If xx <= g1 And xx >= 0 And yy <= g1 And yy >= 0 Then
            arr(x, y) = arr(xx, yy) 'Обмен выбранного значениями с нулем
            arr(xx, yy) = 0 'Выбранной клетке ставим ноль
            x = xx: y = yy: i = i + 1
        End If
 
    Loop While i < 1000 'Число сдвигов пустой клетки этого будет достаточно
    
    
End Sub
 
Sub NewPlay()
    'Новая игра
    '
    Dim i&, j&, ii&, jj&, k$, arr(), r As Range
    Application.ScreenUpdating = False
    Call reset
    CreateArr arr
 
    For i = minRow To maxRow Step 3
        For j = minCol To maxCol
            With Range(Cells(i, j), Cells(i + 2, j))
                .Merge: ii = (i - minRow) \ 3: jj = j - minCol
                If arr(ii, jj) = 0 Then
                    Set r = Range(Cells(i, j), Cells(i + 2, j))
                Else
                    .Value = arr(ii, jj)
                End If
            End With
        Next
    Next
    
    With Range(Cells(minRow, minCol), Cells(maxRow + 2, maxCol))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        With .Font
            .Name = "Cooper Black"
            .Size = 22
        End With
 
        For i = 7 To 12
            With .Borders(i)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        Next
        .Interior.ColorIndex = Busy
    End With
    With r
        .Interior.ColorIndex = Free
        .Select
    End With
    Counter True
    Application.ScreenUpdating = True
End Sub
 
 
Private Sub CheckResult()
    Dim i&, j&, ch&
    For i = minRow To maxRow Step 3
        For j = minCol To maxCol
        ch = ch + 1
        If Cells(i, j).Value <> ch Then Exit Sub
        If ch = maxGrid Then Exit For
    Next j, i
    If MsgBox("Победа !" & vbLf & "Начать заново ?", 68) = vbYes Then NewPlay
    
End Sub
 
 
 
Private Sub Counter(Optional ByVal ResetCoun As Boolean)
    If ResetCoun Then
        Total = 0
    Else
        Total = Total + 1
    End If
    [h6] = "Число ходов: " & Total
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim v, r As Range
    If Target.Count = 3 And Target.Interior.ColorIndex = Busy Then
        'Если нажата занятая клетка
        '
        On Error Resume Next
        For Each v In Array(Array(-3, 0), Array(0, 1), Array(3, 0), Array(0, -1))
            'проверка соседних клеток (куда можно переместиться)
            '
            Set r = Nothing: Set r = Cells(Target.Row + v(0), Target.Column + v(1))
            If Not r Is Nothing Then
                If r.Interior.ColorIndex = Free Then
                    Set r = Range(r, Cells(r.Row + 2, r.Column))
                    r.Interior.ColorIndex = Busy: r.Value = Target.Value
                    Target.Value = "": Target.Interior.ColorIndex = Free
                    Call Counter 'Счетчик ходов
                    Call CheckResult  'Проверка на победу :)
                End If
            End If
        Next
    End If
 
End Sub
 
Private Sub reset()
    'Сброс форматирования
    '
    [a1].Copy
    With Columns("B:Z")
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False: Application.CutCopyMode = False
        .ClearContents
    End With
End Sub
 
 
 
 
Private Sub CommandButton1_Click()
    Call NewPlay
End Sub
1
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
03.04.2019, 11:48 172
Еще дополнение от пользователя Аксима: Игра-15_3.xls
0
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
04.04.2019, 13:19 173
Графический ввод пароля

Для тех кто хотел-бы защитить свой документ необычным способом, можете изучить этот топик

Тема обсуждения: здесь



Лист: Графический пароль.xls
2
FireHeadChaos
3 / 3 / 0
Регистрация: 06.03.2019
Сообщений: 40
04.04.2019, 18:03 174
Выкладываю программу для работы с новыми алкогольными марками. Программа может загружать идентификаторы, из csv, txt, проверять их, выгружать в txt, объединять файлы из папки в один. Сортировать диапазоны и показывать диапазоны. Также можно сканировать в режиме клавиатуры сразу на рабочий лист на котором есть инструменты обработки штрих-кода.
2
Вложения
Тип файла: rar Проверка и сбор ШК.rar (102.9 Кб, 6 просмотров)
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
05.04.2019, 15:17 175
Аналоговые часы +

Тема обсуждений: здесь



Архив с листом: Аналоговые часы+.rar
1
fever brain
oh my god
1381 / 736 / 154
Регистрация: 05.01.2016
Сообщений: 2,237
Записей в блоге: 7
05.04.2019, 21:29 176
---


Аналоговые часы+.rar (обновлено)
2
Catstail
Модератор
25222 / 12884 / 2386
Регистрация: 12.02.2012
Сообщений: 21,016
09.06.2019, 09:11 177
Моя статья Функциональные интерфейсы... в VBA на хабре.
5
Catstail
Модератор
25222 / 12884 / 2386
Регистрация: 12.02.2012
Сообщений: 21,016
09.06.2019, 13:52 178
Прилагаю реализацию с примерами кода. Числа Фибоначчи в функциональном стиле:

Visual Basic
1
2
3
4
5
6
7
8
Sub Test_5() 
Dim fibGen As aIter
    Set fibGen = New Generator
    fibGen.Init Array(1, 0), "(c,p)->c+p"
    For i% = 1 To 50
        Debug.Print fibGen.getNext()
    Next i%
End Sub
5
Вложения
Тип файла: zip FP-09.zip (50.4 Кб, 11 просмотров)
The trick
Модератор
8106 / 2827 / 778
Регистрация: 22.02.2013
Сообщений: 3,962
Записей в блоге: 77
11.06.2019, 01:23 179
Класс таймера.

Класс который реализует функцию таймера для VBA/VB6. Совместим с 64 битным офисом. Для использования нужно просто добавить модуль в проект, задать интервал и ловить события Tick. Модуль имеет небольшую проверку позволяющего уменьшить количество сбоев при отладке.

Ссылка.
2
art1289
157 / 123 / 37
Регистрация: 02.08.2019
Сообщений: 436
Записей в блоге: 8
16.09.2019, 07:06 180
Моя надстройка: Macro Tools VBA – инструменты разработки макросов VBATools


Инструмент автоматизации разработки макросов в редакторе Visual Basic Editor для MS Excel

Основные преимущества Macro Tools VBA:

• установка, не требующая от пользователя прав администратора
• открытый исходный код
• платформа независимость - работает на версиях MS Excel 32 bit и 64 bit
• русскоязычный интерфейс
• бесплатная

Основные функции Macro Tools VBA:

• удаление паролей с проектов VBA, книг и листов Excel
• автоматическое форматирование кода, расстановка и удаление отступов в коде (функционал надстройки: Smart Indenter)
• автоматическая нумерации строк кода
• микро подстройка элементов в формах
• переименование элементов в формах одновременно с кодом
• обфускация кода в проекте VBA
• выдавать подробную статистику по проекту (кол-во строк кода, процедур, элементов на формах и т.д.)
• имеет свою базу заготовок кода (Code-Library), для типичных случаев с быстрой вставкой в новых макросах
• возможность дополнить Code-Library своими заготовками кода
• автоматическая распаковка и запаковка файла Excel

Файл для установки находится тут: Macro Tools VBA – инструменты разработки макросов VBATools.ru

Сылка на блог надстройки: Macro Tools VBA – инструменты разработки макросов VBATools
3
16.09.2019, 07:06
Answers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
16.09.2019, 07:06

Хранить шаблоны документов в базе и выводить данные в эти шаблоны
Доброго времени суток. Интересует вопрос: мне необходимо формировать вордовские документы по...

Библиотеки программы
Знаю, что подобные темы обсуждались, но ничего путного не нашел. Написал программу CLR, но...

Чем отличаются шаблоны HTML и шаблоны WordPress
В чём различие между шаблонами HTML и WordPress. Кроме того, что создаются они разными способами....


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
180
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2019, vBulletin Solutions, Inc.