Здравствуйте! Подскажите что нужно дописать чтоб не было конфликта двух обработчиков событий на одном листе
[vba]
Код
Dim Coord_Selection As Boolean 'глобальная переменная для вкл/выкл выделения
[/vba]
[vba]
Код
Sub Selection_On() 'макрос включения выделения Coord_Selection = True End Sub
[/vba]
[vba]
Код
Sub Selection_Off() 'макрос выключения выделения Coord_Selection = False End Sub
[/vba]
[vba]
Код
'основная процедура, выполняющая выделение Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim WorkRange As Range
If Target.Cells.Count > 1 Then Exit Sub 'если выделено больше 1 ячейки - выходим If Coord_Selection = False Then Exit Sub 'если выделение выключено - выходим
Application.ScreenUpdating = False Set WorkRange = Range("A1:AU10000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate End Sub
[/vba] [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row)) Is Nothing Then rw = Target.Row If Selection.Address = "$A$" & rw & ":$M$" & rw Then With Sheets("Для Бухг") Selection.copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) Beep End With End If End If End Sub
[/vba]
Здравствуйте! Подскажите что нужно дописать чтоб не было конфликта двух обработчиков событий на одном листе
[vba]
Код
Dim Coord_Selection As Boolean 'глобальная переменная для вкл/выкл выделения
[/vba]
[vba]
Код
Sub Selection_On() 'макрос включения выделения Coord_Selection = True End Sub
[/vba]
[vba]
Код
Sub Selection_Off() 'макрос выключения выделения Coord_Selection = False End Sub
[/vba]
[vba]
Код
'основная процедура, выполняющая выделение Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim WorkRange As Range
If Target.Cells.Count > 1 Then Exit Sub 'если выделено больше 1 ячейки - выходим If Coord_Selection = False Then Exit Sub 'если выделение выключено - выходим
Application.ScreenUpdating = False Set WorkRange = Range("A1:AU10000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate End Sub
[/vba] [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row)) Is Nothing Then rw = Target.Row If Selection.Address = "$A$" & rw & ":$M$" & rw Then With Sheets("Для Бухг") Selection.copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) Beep End With End If End If End Sub
plohish, пишите подробнее: в моем файле из предыдущего сообщения или Вы уже успели что-то изменить? На какой строчке?
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim WorkRange As Range Application.ScreenUpdating = False If Target.Cells.Count = 1 Then Application.EnableEvents = False Set WorkRange = Range("A1:AU10000") Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select Target.Activate Application.EnableEvents = True End If
If Not Intersect(Target, Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row)) Is Nothing Then rw = Target.Row If Selection.Address = "$A$" & rw & ":$M$" & rw Then Application.EnableEvents = False With Sheets(1) Selection.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) Beep End With Application.EnableEvents = True End If End If End Sub
[/vba]
plohish, пишите подробнее: в моем файле из предыдущего сообщения или Вы уже успели что-то изменить? На какой строчке?
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim WorkRange As Range Application.ScreenUpdating = False If Target.Cells.Count = 1 Then Application.EnableEvents = False Set WorkRange = Range("A1:AU10000") Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select Target.Activate Application.EnableEvents = True End If
If Not Intersect(Target, Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row)) Is Nothing Then rw = Target.Row If Selection.Address = "$A$" & rw & ":$M$" & rw Then Application.EnableEvents = False With Sheets(1) Selection.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) Beep End With Application.EnableEvents = True End If End If End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.Count > 13 Then Exit Sub 'если выделено больше 1 ячейки - выходим If Target.Cells.Count = 1 Then If Coord_Selection = False Then Exit Sub 'если выделение выключено - выходим
Application.EnableEvents = False 'Range("A1:AU10000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(Range("A1:AU10000"), Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate Application.EnableEvents = True End If
rw = Target.Row If rw <> Cells(Rows.Count, 1).End(xlUp).Row Then Exit Sub If Selection.Address = "$A$" & rw & ":$M$" & rw Then Selection.Copy Sheets("Для Бухг").Cells(Rows.Count, 1).End(xlUp)(2, 1) Beep End If End Sub
[/vba]
а если так: [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.Count > 13 Then Exit Sub 'если выделено больше 1 ячейки - выходим If Target.Cells.Count = 1 Then If Coord_Selection = False Then Exit Sub 'если выделение выключено - выходим
Application.EnableEvents = False 'Range("A1:AU10000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(Range("A1:AU10000"), Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate Application.EnableEvents = True End If
rw = Target.Row If rw <> Cells(Rows.Count, 1).End(xlUp).Row Then Exit Sub If Selection.Address = "$A$" & rw & ":$M$" & rw Then Selection.Copy Sheets("Для Бухг").Cells(Rows.Count, 1).End(xlUp)(2, 1) Beep End If End Sub
Dim Coord_Selection As Boolean 'глобальная переменная для вкл/выкл выделения Sub Selection_On() 'макрос включения выделения Coord_Selection = True End Sub Sub Selection_Off() 'макрос выключения выделения Coord_Selection = False End Sub
[/vba] и лист "Для Бухг" должен быть в наличии
ну эти строки тоже ведь надо добавить: [vba]
Код
Dim Coord_Selection As Boolean 'глобальная переменная для вкл/выкл выделения Sub Selection_On() 'макрос включения выделения Coord_Selection = True End Sub Sub Selection_Off() 'макрос выключения выделения Coord_Selection = False End Sub
[/vba] и лист "Для Бухг" должен быть в наличииnilem
plohish, Вы случайно не добавляете строчку Option Explicit. Добавьте в начало макроса объявление для rw [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rw As Integer
[/vba] У меня работают все предложенные в этой теме варианты. Кстати, обратите внимание, в моем макросе и в макросе Pelena, копируется любая строчка A:M, а в макросе nilem, только последняя. Как Вам нужно - не знаю, просто на всякий случай указываю на это.
plohish, Вы случайно не добавляете строчку Option Explicit. Добавьте в начало макроса объявление для rw [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rw As Integer
[/vba] У меня работают все предложенные в этой теме варианты. Кстати, обратите внимание, в моем макросе и в макросе Pelena, копируется любая строчка A:M, а в макросе nilem, только последняя. Как Вам нужно - не знаю, просто на всякий случай указываю на это.Manyasha