Прошу поправить макрос. При нажатии кнопки выдает ошибку и выделяет желтым первую строку "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]
Прошу поправить макрос. При нажатии кнопки выдает ошибку и выделяет желтым первую строку "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)
Хех... Вам же там посоветовали в процедуру perenos вставить только нужный вам для функционала код, а не засовывать в неё всё содержимое модуля страницы
Я так и не понял вашего "по-разному пробовал". Потому что вам посоветовали всё,что нужно проделать - содержимое процедуры Worksheet_Change() перенести в новую процедуру, изменить код, чтобы эта новая процедура правильно заработала, и подвесить эту новую процедуру на кнопочку. А если вам надо "сделайте всё за меня" - так и пишите, не стесняйтесь. И вам сделают. Или не сделают...
Хех... Вам же там посоветовали в процедуру perenos вставить только нужный вам для функционала код, а не засовывать в неё всё содержимое модуля страницы
Я так и не понял вашего "по-разному пробовал". Потому что вам посоветовали всё,что нужно проделать - содержимое процедуры Worksheet_Change() перенести в новую процедуру, изменить код, чтобы эта новая процедура правильно заработала, и подвесить эту новую процедуру на кнопочку. А если вам надо "сделайте всё за меня" - так и пишите, не стесняйтесь. И вам сделают. Или не сделают...AndreTM
Skype: andre.tm.007 Donate: Qiwi: 9517375010
Сообщение отредактировал AndreTM - Среда, 12.08.2015, 14:19
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]
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
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]
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