Как зациклить макрос excel

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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269

Sub Макрос1()
'
' Макрос1 Макрос
' Макрос записан 20.01.2014 (Владимир)
'
' Сочетание клавиш: Ctrl+ф
'
    Range("E2").Select
    Selection.Copy
    Range("J2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("E2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("K2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("L2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("M2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("N2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("O2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("P2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("Q2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("R2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("S2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll ToRight:=13
    Range("T2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("U2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("V2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("W2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("X2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("Y2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("Z2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AA2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AB2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AC2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AD2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AE2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AF2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll ToRight:=18
    Range("AG2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AH2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AI2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AJ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AK2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AL2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AM2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AN2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AO2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AP2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AQ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AR2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AS2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AT2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AU2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AV2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AW2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AX2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    ActiveWindow.SmallScroll ToRight:=4
    Range("AX2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AY2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("AZ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BA2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BB2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll ToRight:=9
    Range("BC2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BD2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BE2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BF2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BG2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BH2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BI2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BJ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BK2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll ToRight:=7
    Range("BL2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BM2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BN2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BO2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BP2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BQ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BR2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BS2").Select
    ActiveWindow.SmallScroll ToRight:=5
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BT2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BU2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BV2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BW2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll ToRight:=17
    Range("BX2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BY2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("BZ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CA2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CB2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CC2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CD2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CE2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CF2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CG2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CH2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CI2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CJ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CK2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("CL2").Select
    ActiveWindow.LargeScroll ToRight:=-4
    Range("J2:CK16349").Select
    Application.CutCopyMode = False
    Selection.Cut Destination:=Range("J3:CK16350")
    Range("J3:CK16350").Select
End Sub
Источник

Подскажите пожалуйста. Как зациклить макрос Excel? так нужно пройти до 3000 строк. Спасибо

Sub Макрос3()
‘
‘ Макрос3 Макрос
‘

‘
ActiveCell.FormulaR1C1 = «0»
Range(«A14»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A15»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A16»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A17»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A18»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A19»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A20»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A21»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A22»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A23»).Select
ActiveCell.FormulaR1C1 = «0»
Range(«A24»).Select
End Sub

Источник

You can actually reduce your code.

First Tip:

Please avoid the use of .Select/.Activate INTERESTING READ

Second Tip:

Instead of doing an Autofill, you can enter the formula in the relevant cells in one go. For example. this

Range("G2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]/RC[-1]*100"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G19"), Type:=xlFillDefault

can be written as

Range("G2:G19").FormulaR1C1 = "=RC[-2]/RC[-1]*100"

Third Tip:

You don’t need to do a copy and paste in separate lines. You can do it in one line. For example

Range("A2:C2").Select
Selection.Copy
Sheets("Sheet2_Transposed data").Select
Range("A2").Select
ActiveSheet.Paste

can be written as

Range("A2:C2").Copy Sheets("Sheet2_Transposed data").Range("A2")

Same thing when you are doing a PasteSpecial. But you use .Value = .Value soo this

Range("G2:G19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1_Transposed_data").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True

can be written as

Sheets("Sheet1_Transposed_data").Range("D2:D19").Value = _
Sheets("Sheet1").Range("G2:G19").Value

Missed the Transpose part. (Thanks Simoco). In this case, you can write the code as

Range("A2:C2").Copy 
Sheets("Sheet2_Transposed data").Range("D2").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True

Fourth Tip:

To loop through cells, you can use a For Loop. Say you want to loop though cells A2 to A20 then you can do like this

For i = 2 To 20
    With Range("A" & i)
        '
        '~~> Do Something
        '
    End With
Next i

EDIT:

Your before and after Screenshots (From Comments):

enter image description here

and

enter image description here

After seeing your screenshots, I guess this is what you are trying? This is untested as I just quickly wrote it. Let me know if you get any errors :) 

Sub test()
    Dim wsInPut As Worksheet, wsOutput As Worksheet
    Dim lRow As Long, NewRw As Long, i As Long

    '~~> Set your sheets here
    Set wsInPut = ThisWorkbook.Sheets("Sheet1_session_data")
    Set wsOutput = ThisWorkbook.Sheets("Sheet2_Transposed data")

    '~~> Start row in "Sheet2_Transposed data"
    NewRw = 2

    With wsInPut
        '~~> Find Last Row
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Calculate the average in one go
        .Range("G2:G" & lRow).FormulaR1C1 = "=RC[-2]/RC[-1]*100"

        '~~> Loop through the rows
        For i = 2 To lRow Step 18
            wsOutput.Range("A" & NewRw).Value = .Range("A" & i).Value
            wsOutput.Range("B" & NewRw).Value = .Range("B" & i).Value
            wsOutput.Range("C" & NewRw).Value = .Range("C" & i).Value

            .Range("G" & i & ":G" & (i + 17)).Copy

            wsOutput.Range("D" & NewRw).PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=True

            NewRw = NewRw + 1
        Next i

        wsOutput.Range("D2:U" & (NewRw - 1)).NumberFormat = "0"
    End With
End Sub

Источник

При работе с Microsoft Excel вам может потребоваться создание макросов для выполнения некоторых операций. Например, вы хотите создать макрос для автоматического копирования диапазона данных в новое место. Поскольку данные будут часто меняться, вам необходимо, чтобы этот макрос запускался автоматически каждые 5 минут без его ручного запуска, чтобы синхронизировать эти два диапазона данных. Как этого добиться? Метод, описанный в этой статье, может вам помочь.

Повторять или зацикливать макрос каждые X минут в Excel

Повторять или зацикливать макрос каждые X минут в Excel

Следующий код VBA может помочь вам повторять макрос каждые X минут в Excel. Пожалуйста, сделайте следующее.

1. Нажмите другой + F11 в то же время, чтобы открыть Microsoft Visual Basic для приложений окно.

2. в Microsoft Visual Basic для приложений окно, пожалуйста, нажмите Вставить > Модули. Затем скопируйте и вставьте приведенный ниже код VBA в Code окно. Смотрите скриншот:

Код VBA: повторять или зацикливать макрос каждые X минут в Excel

Sub ReRunMacro()
Dim xMin As String

'Insert your code here
    xMin = GetSetting(AppName:="Kutools", Section:="Macro", Key:="min", Default:="")
    If xMin = "Exit" Then
    SaveSetting "Kutools", "Macro", "min", "False"
    Exit Sub
    End If
    If (xMin = "") Or (xMin = "False") Then
      xMin = Application.InputBox(prompt:="Please input the interval time you need to repeat the Macro", Title:="Kutools for Excel", Type:=2)
      SaveSetting "Kutools", "Macro", "min", xMin
    End If
    If (xMin <> "") And (xMin <> "False") Then
      Application.OnTime Now() + TimeValue("0:" + xMin + ":0"), "ReRunMacro"
    Else
      Exit Sub
    End If
End Sub

Внимание: В коде замените эту строку ‘Вставьте сюда свой код с кодом вы будете запускаться каждые X минут.

3. нажмите F5 ключ для запуска кода. В всплывающем Kutools for Excel диалоговое окно, введите интервал времени, в течение которого будет повторяться макрос, а затем нажмите кнопку OK кнопка. Смотрите скриншот:

С этого момента определенный макрос будет запускаться в вашей книге каждые 5 минут.

Внимание: Если вам нужно остановить выполнение макроса и изменить интервал цикла, скопируйте приведенный ниже код VBA в тот же Модули окно и нажмите F5 ключ для запуска кода. После этого макрос будет остановлен. Повторите приведенный выше код, чтобы указать новый интервал.

Код VBA: остановить выполнение макроса

Sub ExitReRunMacro()
SaveSetting "Kutools", "Macro", "min", "Exit"
End Sub

Office Tab — Просмотр, редактирование и управление книгами в Excel с вкладками:

Вкладка Office предоставляет интерфейс с вкладками, как в веб-браузерах, таких как Google Chrome, новые версии Internet Explorer и Firefox в Microsoft Excel. Он станет незаменимым помощником в работе и сэкономит время. См. Демонстрацию ниже:

Нажмите, чтобы получить бесплатную пробную версию вкладки Office!

Вкладка Office для Excel

Статьи по теме:

  • Как повторить строки при прокрутке листа в Excel?
  • Как повторить последнее или предыдущее действие в Excel?
  • Как повторно печатать строки внизу каждой распечатанной страницы в Excel?
  • Как повторять значение ячейки, пока новое значение не будет видно или достигнуто в Excel?

Лучшие инструменты для работы в офисе

Kutools for Excel Решит большинство ваших проблем и повысит вашу производительность на 80%

  • Снова использовать: Быстро вставить сложные формулы, диаграммы и все, что вы использовали раньше; Зашифровать ячейки с паролем; Создать список рассылки и отправлять электронные письма …
  • Бар Супер Формулы (легко редактировать несколько строк текста и формул); Макет для чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон…
  • Объединить ячейки / строки / столбцы без потери данных; Разделить содержимое ячеек; Объединить повторяющиеся строки / столбцы… Предотвращение дублирования ячеек; Сравнить диапазоны…
  • Выберите Дубликат или Уникальный Ряды; Выбрать пустые строки (все ячейки пустые); Супер находка и нечеткая находка во многих рабочих тетрадях; Случайный выбор …
  • Точная копия Несколько ячеек без изменения ссылки на формулу; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое …
  • Извлечь текст, Добавить текст, Удалить по позиции, Удалить пробел; Создание и печать промежуточных итогов по страницам; Преобразование содержимого ячеек в комментарии…
  • Суперфильтр (сохранять и применять схемы фильтров к другим листам); Расширенная сортировка по месяцам / неделям / дням, периодичности и др .; Специальный фильтр жирным, курсивом …
  • Комбинируйте книги и рабочие листы; Объединить таблицы на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF…
  • Более 300 мощных функций. Поддерживает Office/Excel 2007-2021 и 365. Поддерживает все языки. Простое развертывание на вашем предприятии или в организации. Полнофункциональная 30-дневная бесплатная пробная версия. 60-дневная гарантия возврата денег.

вкладка kte 201905

Вкладка Office: интерфейс с вкладками в Office и упрощение работы

  • Включение редактирования и чтения с вкладками в Word, Excel, PowerPoint, Издатель, доступ, Visio и проект.
  • Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
  • Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!

офисный дно

Комментарии (31)


Оценок пока нет. Оцените первым!

Источник
 

Есть макрос поиска значения в таблице:  
Sub Finderer()  
Dim FD, firstAddress, adrs  
FD = InputBox(«ВВЕДИТЕ ИНВЕНТАРНЫЙ НОМЕР ОС или отсканируйте его», «ПОИСК ОС»)  
If FD = «» Then Exit Sub ‘ если пользователь нажал кнопку ОТМЕНА — отказ от поиска  
Dim c As Range: Set c = Range(«A:A»).Find(FD) ‘ поиск данных  
‘ если ничего не нашли — выход из макроса  
If c Is Nothing Then MsgBox «Искомые данные не найдены», vbExclamation: Exit Sub  
firstAddress = c.Address  
c.Select  
Do  
adrs = adrs & vbLf & c.Address(0, 0)  
Union(Selection, c).Select  
Set c = Range(«A:A»).FindNext©  
Loop While c.Address <> firstAddress  
Selection.Interior.ColorIndex = 4  
End Sub  

  Скажите, пожалуйста, как сделать так — чтобы окно после поиска и выделения не закрывалось (просто выделалась найденная ячейка). Тесть чтобы окно с запросом данных выводилось и дальше до момента когда значение не будет найдено, тогда сообщение об ошибке. А если бы ещё сделать так, чтобы когда значение найдено — то в колонке «М» этой же строчки ставилась единичка (для последующей фильтрации).  
Заранее благодарен!!!
 

А выводить новое окно при нахождении искомого слова не подойдет?
 

Походу подойдет, но как это сделать, я не силен в макросах :(

 

ikki

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

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

а зачем вам вообще макросы?  
имхо, расширенного фильтра хватит.  
сразу задаете в диапазоне критериев перечень номеров — и запускаете фильтр.

фрилансер Excel, VBA — контакты в профиле
«Совершенствоваться не обязательно. Выживание — дело добровольное.» Э.Деминг

 

В общем для проведения инвентаризации ОС. Из АБС выгружается список основных средств, на каждом ОС есть наклейка с номером и штрих кодом. С помочью сканера штрих доков нужно каждое ОС «пропикать», потом можно будет по фильтру посмотреть каких ОС нету…
 

Baklanoff

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

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

Дилетантство, знаю. Но все же…  
После строки    

  Dim FD, firstAddress, adrs  
вставьте строку    
Do Until FD=»»  
А перед строкой End Sub добавьте строку Loop.  
Не тестировал, но вроде должно работать.
 

Не работает. По нажатию кнопки окно с запросом не появляется вообще.
 

Baklanoff

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

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

Пробуйте  

  Sub Finderer()  
Dim FD, firstAddress, adrs  
FD = » »  
Do Until FD = «»  
FD = InputBox(«ÂÂÅÄÈÒÅ ÈÍÂÅÍÒÀÐÍÛÉ ÍÎÌÅÐ ÎÑ èëè îòñêàíèðóéòå åãî», «ÏÎÈÑÊ ÎÑ»)  
If FD = «» Then Exit Sub ‘ åñëè ïîëüçîâàòåëü íàæàë êíîïêó ÎÒÌÅÍÀ — îòêàç îò ïîèñêà  
Dim c As Range: Set c = Range(«A:A»).Find(FD) ‘ ïîèñê äàííûõ  
‘ åñëè íè÷åãî íå íàøëè — âûõîä èç ìàêðîñà  
If c Is Nothing Then MsgBox «Èñêîìûå äàííûå íå íàéäåíû», vbExclamation: Exit Sub  
firstAddress = c.Address  
c.Select  
Do  
adrs = adrs & vbLf & c.Address(0, 0)  
Union(Selection, c).Select  
Set c = Range(«A:A»).FindNext©  
Loop While c.Address <> firstAddress  
Selection.Interior.ColorIndex = 4  
Loop  
End Sub
 

Baklanoff

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

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

Забыл, сори  

  Sub Finderer()  
Dim FD, firstAddress, adrs  
FD = » »  
Do Until FD = «»  
FD = InputBox(«ВВЕДИТЕ ИНВЕНТАРНЫЙ НОМЕР ОС или отсканируйте его», «ПОИСК ОС»)  
If FD = «» Then Exit Sub ‘ если пользователь нажал кнопку ОТМЕНА — отказ от поиска  
Dim c As Range: Set c = Range(«A:A»).Find(FD) ‘ поиск данных  
‘ если ничего не нашли — выход из макроса  
If c Is Nothing Then MsgBox «Искомые данные не найдены», vbExclamation: Exit Sub  
firstAddress = c.Address  
c.Select  
Do  
adrs = adrs & vbLf & c.Address(0, 0)  
Union(Selection, c).Select  
Set c = Range(«A:A»).FindNext©  
Loop While c.Address <> firstAddress  
Selection.Interior.ColorIndex = 4  
Loop  
End Sub
 

Hugo

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

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

Грузите список своих пропиканных в массив->словарь, затем основные в массив->проверка по словарю, запись найденных/ненайденных в массив или коллекцию, выгрузка.  
Можно и покрасить на листе, но это долго.  
А так — секундное дело, и код проще, чем тут выше понаписанный.
 

Baklanoff  

  Большое спасибо за помощь, но не работает :(  
Прикрепил образец файла…
 

Hugo  

  Хотят, так сказать, в режиме реального времени, пикнули — сразу увидели результат. Если нету сразу — сразу кто то начинает искать, а инвентаризация идет дальше, так как объектов много а времени мало
 

Baklanoff

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

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

Hugo

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

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

Ну можно наоборот — сперва список основных средств в публичный словарь, который всё время будет в памяти.  
Затем по каждому пику (по событию изменения на листе) сразу по словарю получаем ответ — есть такое или нет.  
Без всяких поисков, мнгновенно.  
Хотя если список средств ~100000, то можно и на каждый пик создавать словарь, это заметно не будет, доля секунды.  
Хотя конечно зависит от машины…
 

Baklanoff

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

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

Lihodej

Гость

#16

27.11.2012 18:34:06

Baklanoff Большое спасибо! Все работает.  

  Ещё такой нескромный вопрос, а можно сделать так, чтобы кода значение в форме поиска не было найдено на листе, тогда после сообщение об отсутствии оно копировалось на другой лист, скажем «не найдено», и поиск производился дальше (форма не закрывалась)?  

  Заранее благодарен за ответ!
Источник

Понравилась статья? Поделить с друзьями:
  • Как зафиксировать столбец или строку в excel
  • Как захешировать данные в md5 excel
  • Как зафиксировать столбец в word
  • Как зафиксировать ячейку с помощью одной клавиши в excel
  • Как зафиксировать столбец в excel формула