Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Исправление автоматического макроса на макрос для кнопки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Исправление автоматического макроса на макрос для кнопки (Макросы/Sub)
Исправление автоматического макроса на макрос для кнопки
den45444 Дата: Среда, 12.08.2015, 11:36 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Прошу поправить макрос. При нажатии кнопки выдает ошибку и выделяет желтым первую строку "Sub perenos()"

[vba]
Код
Sub perenos()

Private Sub Worksheet_Activate()

End Sub

Private Sub Worksheet_Calculate()

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rez(), start As Boolean, tmp As Range
If Target(1).Address = [A3].Address Then
If InStrRev([A3], "¹") > 0 Then
EtapN = Val(Split([A3], "¹")(1))
EndRow = Range("A1000").End(xlUp).Row
If EndRow > 5 Then Range("A6", "E" & EndRow).ClearContents
rez = Application.Transpose([A5:E5].Value)
If EtapN Then
arr = Ëèñò1.Range("A5", "I" & Ëèñò1.Range("A1000").End(xlUp).Row).Value
start = False
For i = 1 To UBound(arr)
If start Then
If InStr(1, arr(i, 1), "Èòîãî") > 0 Then
ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2) + 1)
rez(1, UBound(rez, 2)) = arr(i, 1)
rez(5, UBound(rez, 2)) = arr(i, 7)
Exit For
ElseIf Not arr(i, 1) = "" Then
ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2) + 1)
rez(1, UBound(rez, 2)) = arr(i, 1)
rez(2, UBound(rez, 2)) = arr(i, 3)
rez(3, UBound(rez, 2)) = arr(i, 4)
rez(4, UBound(rez, 2)) = arr(i, 5)
rez(5, UBound(rez, 2)) = arr(i, 7)
End If
Else
If InStr(arr(i, 1), "Ýòàï") > 0 Then
If InStrRev([A3], "¹") > 0 Then
If Val(Split(arr(i, 1), "¹")(1)) = EtapN Then start = True
End If
End If
End If
Next i
End If
Range("A5", Range("A5").Offset(UBound(rez, 2) - 1, UBound(rez) - 1).Address).Rows.Value = Application.Transpose(rez)
End If
End If
End Sub

Private Sub Worksheet_Deactivate()

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

End Sub
[/vba]


Сообщение отредактировал den45444 - Среда, 12.08.2015, 13:54
 
Ответить
СообщениеПрошу поправить макрос. При нажатии кнопки выдает ошибку и выделяет желтым первую строку "Sub perenos()"

[vba]
Код
Sub perenos()

Private Sub Worksheet_Activate()

End Sub

Private Sub Worksheet_Calculate()

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rez(), start As Boolean, tmp As Range
If Target(1).Address = [A3].Address Then
If InStrRev([A3], "¹") > 0 Then
EtapN = Val(Split([A3], "¹")(1))
EndRow = Range("A1000").End(xlUp).Row
If EndRow > 5 Then Range("A6", "E" & EndRow).ClearContents
rez = Application.Transpose([A5:E5].Value)
If EtapN Then
arr = Ëèñò1.Range("A5", "I" & Ëèñò1.Range("A1000").End(xlUp).Row).Value
start = False
For i = 1 To UBound(arr)
If start Then
If InStr(1, arr(i, 1), "Èòîãî") > 0 Then
ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2) + 1)
rez(1, UBound(rez, 2)) = arr(i, 1)
rez(5, UBound(rez, 2)) = arr(i, 7)
Exit For
ElseIf Not arr(i, 1) = "" Then
ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2) + 1)
rez(1, UBound(rez, 2)) = arr(i, 1)
rez(2, UBound(rez, 2)) = arr(i, 3)
rez(3, UBound(rez, 2)) = arr(i, 4)
rez(4, UBound(rez, 2)) = arr(i, 5)
rez(5, UBound(rez, 2)) = arr(i, 7)
End If
Else
If InStr(arr(i, 1), "Ýòàï") > 0 Then
If InStrRev([A3], "¹") > 0 Then
If Val(Split(arr(i, 1), "¹")(1)) = EtapN Then start = True
End If
End If
End If
Next i
End If
Range("A5", Range("A5").Offset(UBound(rez, 2) - 1, UBound(rez) - 1).Address).Rows.Value = Application.Transpose(rez)
End If
End If
End Sub

Private Sub Worksheet_Deactivate()

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

End Sub
[/vba]
Автор - den45444
Дата добавления - 12.08.2015 в 11:36
AndreTM Дата: Среда, 12.08.2015, 13:28 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1762
Репутация: 500 ±
Замечаний: 0% ±

2003 & 2010
Хех...
Вам же там посоветовали в процедуру perenos вставить только нужный вам для функционала код, а не засовывать в неё всё содержимое модуля страницы :)

Я так и не понял вашего "по-разному пробовал". Потому что вам посоветовали всё,что нужно проделать - содержимое процедуры Worksheet_Change() перенести в новую процедуру, изменить код, чтобы эта новая процедура правильно заработала, и подвесить эту новую процедуру на кнопочку.
А если вам надо "сделайте всё за меня" - так и пишите, не стесняйтесь. И вам сделают. Или не сделают...

Skype: andre.tm.007
Donate: Qiwi: 9517375010

Сообщение отредактировал AndreTM - Среда, 12.08.2015, 14:19
 
Ответить
СообщениеХех...
Вам же там посоветовали в процедуру perenos вставить только нужный вам для функционала код, а не засовывать в неё всё содержимое модуля страницы :)

Я так и не понял вашего "по-разному пробовал". Потому что вам посоветовали всё,что нужно проделать - содержимое процедуры Worksheet_Change() перенести в новую процедуру, изменить код, чтобы эта новая процедура правильно заработала, и подвесить эту новую процедуру на кнопочку.
А если вам надо "сделайте всё за меня" - так и пишите, не стесняйтесь. И вам сделают. Или не сделают...
Автор - AndreTM
Дата добавления - 12.08.2015 в 13:28
den45444 Дата: Среда, 12.08.2015, 13:33 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
AndreTM, я по разному пробовал.
И во всех случаях давал ошибку.
можете помочь поправить?

Вот мой пример правки:

[vba]
Код

Sub perenos()

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim rez(), start As Boolean, tmp As Range
     If Target(1).Address = [A3].Address Then
         If InStrRev([A3], "№") > 0 Then
             EtapN = Val(Split([A3], "№")(1))
             rez = Application.Transpose([A5:E5].Value)
             If EtapN Then
                 arr = Лист1.Range("A5", "I" & Лист1.Range("A1000").End(xlUp).Row).Value
                 start = False
                 For i = 1 To UBound(arr)
                     If start Then
                         If InStr(1, arr(i, 1), "Итого") > 0 Then
                             ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2))
                             Exit For
                         ElseIf Not arr(i, 1) = "" Then
                             ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2) + 1)
                             rez(1, UBound(rez, 2)) = arr(i, 1)
                             rez(2, UBound(rez, 2)) = arr(i, 3)
                             rez(3, UBound(rez, 2)) = arr(i, 4)
                             rez(4, UBound(rez, 2)) = arr(i, 5)
                             rez(5, UBound(rez, 2)) = arr(i, 7)
                         End If
                     Else
                         If InStr(arr(i, 1), "Этап") > 0 Then
                             If InStrRev([A3], "№") > 0 Then
                    If Val(Split(arr(i, 1), "№")(1)) = EtapN Then start = True
                             End If
                         End If
                     End If
                 Next i
             End If
             Rows("6:" & 4 + UBound(rez, 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
             Range("A5", Range("A5").Offset(UBound(rez, 2) - 1, UBound(rez) - 1).Address).Rows.Value = Application.Transpose(rez)
         End If
     End If
End Sub
End Sub
[/vba]


Сообщение отредактировал den45444 - Среда, 12.08.2015, 13:49
 
Ответить
СообщениеAndreTM, я по разному пробовал.
И во всех случаях давал ошибку.
можете помочь поправить?

Вот мой пример правки:

[vba]
Код

Sub perenos()

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim rez(), start As Boolean, tmp As Range
     If Target(1).Address = [A3].Address Then
         If InStrRev([A3], "№") > 0 Then
             EtapN = Val(Split([A3], "№")(1))
             rez = Application.Transpose([A5:E5].Value)
             If EtapN Then
                 arr = Лист1.Range("A5", "I" & Лист1.Range("A1000").End(xlUp).Row).Value
                 start = False
                 For i = 1 To UBound(arr)
                     If start Then
                         If InStr(1, arr(i, 1), "Итого") > 0 Then
                             ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2))
                             Exit For
                         ElseIf Not arr(i, 1) = "" Then
                             ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2) + 1)
                             rez(1, UBound(rez, 2)) = arr(i, 1)
                             rez(2, UBound(rez, 2)) = arr(i, 3)
                             rez(3, UBound(rez, 2)) = arr(i, 4)
                             rez(4, UBound(rez, 2)) = arr(i, 5)
                             rez(5, UBound(rez, 2)) = arr(i, 7)
                         End If
                     Else
                         If InStr(arr(i, 1), "Этап") > 0 Then
                             If InStrRev([A3], "№") > 0 Then
                    If Val(Split(arr(i, 1), "№")(1)) = EtapN Then start = True
                             End If
                         End If
                     End If
                 Next i
             End If
             Rows("6:" & 4 + UBound(rez, 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
             Range("A5", Range("A5").Offset(UBound(rez, 2) - 1, UBound(rez) - 1).Address).Rows.Value = Application.Transpose(rez)
         End If
     End If
End Sub
End Sub
[/vba]
Автор - den45444
Дата добавления - 12.08.2015 в 13:33
den45444 Дата: Среда, 12.08.2015, 17:09 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
AndreTM, Прошу прощения, если чем-нибудь обидел. Я в кодах мало чего понимаю.

Вот файл. Изменил код, но выдает ошибку и выделяет слово "Target". Не знаю что это значит.
Код выглядит так:
[vba]
Код
Sub perenos()
     Dim rez(), start As Boolean, tmp As Range
     If Target(1).Address = [A3].Address Then
         If InStrRev([A3], "№") > 0 Then
             EtapN = Val(Split([A3], "№")(1))
             rez = Application.Transpose([A5:E5].Value)
             If EtapN Then
                 arr = Лист1.Range("A5", "I" & Лист1.Range("A1000").End(xlUp).Row).Value
                 start = False
                 For i = 1 To UBound(arr)
                     If start Then
                         If InStr(1, arr(i, 1), "Итого") > 0 Then
                             ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2))
                             Exit For
                         ElseIf Not arr(i, 1) = "" Then
                             ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2) + 1)
                             rez(1, UBound(rez, 2)) = arr(i, 1)
                             rez(2, UBound(rez, 2)) = arr(i, 3)
                             rez(3, UBound(rez, 2)) = arr(i, 4)
                             rez(4, UBound(rez, 2)) = arr(i, 5)
                             rez(5, UBound(rez, 2)) = arr(i, 7)
                         End If
                     Else
                         If InStr(arr(i, 1), "Этап") > 0 Then
                             If InStrRev([A3], "№") > 0 Then
                    If Val(Split(arr(i, 1), "№")(1)) = EtapN Then start = True
                             End If
                         End If
                     End If
                 Next i
             End If
             Rows("6:" & 4 + UBound(rez, 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
             Range("A5", Range("A5").Offset(UBound(rez, 2) - 1, UBound(rez) - 1).Address).Rows.Value = Application.Transpose(rez)
         End If
     End If
End Sub

[/vba]
К сообщению приложен файл: 7308082.xlsm (28.7 Kb)
 
Ответить
СообщениеAndreTM, Прошу прощения, если чем-нибудь обидел. Я в кодах мало чего понимаю.

Вот файл. Изменил код, но выдает ошибку и выделяет слово "Target". Не знаю что это значит.
Код выглядит так:
[vba]
Код
Sub perenos()
     Dim rez(), start As Boolean, tmp As Range
     If Target(1).Address = [A3].Address Then
         If InStrRev([A3], "№") > 0 Then
             EtapN = Val(Split([A3], "№")(1))
             rez = Application.Transpose([A5:E5].Value)
             If EtapN Then
                 arr = Лист1.Range("A5", "I" & Лист1.Range("A1000").End(xlUp).Row).Value
                 start = False
                 For i = 1 To UBound(arr)
                     If start Then
                         If InStr(1, arr(i, 1), "Итого") > 0 Then
                             ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2))
                             Exit For
                         ElseIf Not arr(i, 1) = "" Then
                             ReDim Preserve rez(1 To UBound(rez), 1 To UBound(rez, 2) + 1)
                             rez(1, UBound(rez, 2)) = arr(i, 1)
                             rez(2, UBound(rez, 2)) = arr(i, 3)
                             rez(3, UBound(rez, 2)) = arr(i, 4)
                             rez(4, UBound(rez, 2)) = arr(i, 5)
                             rez(5, UBound(rez, 2)) = arr(i, 7)
                         End If
                     Else
                         If InStr(arr(i, 1), "Этап") > 0 Then
                             If InStrRev([A3], "№") > 0 Then
                    If Val(Split(arr(i, 1), "№")(1)) = EtapN Then start = True
                             End If
                         End If
                     End If
                 Next i
             End If
             Rows("6:" & 4 + UBound(rez, 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
             Range("A5", Range("A5").Offset(UBound(rez, 2) - 1, UBound(rez) - 1).Address).Rows.Value = Application.Transpose(rez)
         End If
     End If
End Sub

[/vba]
Автор - den45444
Дата добавления - 12.08.2015 в 17:09
_Boroda_ Дата: Среда, 12.08.2015, 17:13 | Сообщение № 5
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16675
Репутация: 6481 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Не вникая в код, могу предложить заменить Тарджет на Selection

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеНе вникая в код, могу предложить заменить Тарджет на Selection
Автор - _Boroda_
Дата добавления - 12.08.2015 в 17:13
den45444 Дата: Среда, 12.08.2015, 17:26 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
_Boroda_, заменил. Теперь не ругается, но и не выполняет действие.
 
Ответить
Сообщение_Boroda_, заменил. Теперь не ругается, но и не выполняет действие.
Автор - den45444
Дата добавления - 12.08.2015 в 17:26
den45444 Дата: Четверг, 13.08.2015, 12:21 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Помогли в этой теме

Можно закрыть тему.
 
Ответить
СообщениеПомогли в этой теме

Можно закрыть тему.
Автор - den45444
Дата добавления - 13.08.2015 в 12:21
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Исправление автоматического макроса на макрос для кнопки (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!