Доброе утро! Не удалось найти ответ на мой вопрос в других темах форума, поэтому создаю новую тему. Вопрос, наверное, очень не разумный, но он есть. Суть вопроса, 2 разных макроса, которые по отдельности (на разных листах) работают, а вместе нет. Как я понимаю, проблема в том, что в них содержится повторяющаяся команда "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" и ошибку выдает именно на эту строку. Если завершаю первый макрос End If и прописываю второй (что ранее при других командах помогало), то начинает выдавать ошибку именно на строку завершения.
Первый команда это всплывающие окно поиска по форме
[vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect([Q:Q], Target) Is Nothing Or Target.Address = "$Q$1" Then Exit Sub Cancel = True With Target.Application.ActiveWindow UserForm1.Left = (Target.Left + Target.Width - .VisibleRange.Left) * .Zoom / 100 + .Application.Left + 25 UserForm1.Top = (Target.Top + UserForm1.Height / 2) * .Zoom / 100 + .Application.Top UserForm1.Show 0 End With End Sub
Private Sub Worksheet_Deactivate() Unload UserForm1 End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect([Q:Q], Target) Is Nothing Or Target.Count > 1 Then Unload UserForm1 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
'основная процедура, выполняющая выделение 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("A2:AB1000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate End Sub
[/vba] как это можно исправить?
Доброе утро! Не удалось найти ответ на мой вопрос в других темах форума, поэтому создаю новую тему. Вопрос, наверное, очень не разумный, но он есть. Суть вопроса, 2 разных макроса, которые по отдельности (на разных листах) работают, а вместе нет. Как я понимаю, проблема в том, что в них содержится повторяющаяся команда "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" и ошибку выдает именно на эту строку. Если завершаю первый макрос End If и прописываю второй (что ранее при других командах помогало), то начинает выдавать ошибку именно на строку завершения.
Первый команда это всплывающие окно поиска по форме
[vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect([Q:Q], Target) Is Nothing Or Target.Address = "$Q$1" Then Exit Sub Cancel = True With Target.Application.ActiveWindow UserForm1.Left = (Target.Left + Target.Width - .VisibleRange.Left) * .Zoom / 100 + .Application.Left + 25 UserForm1.Top = (Target.Top + UserForm1.Height / 2) * .Zoom / 100 + .Application.Top UserForm1.Show 0 End With End Sub
Private Sub Worksheet_Deactivate() Unload UserForm1 End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect([Q:Q], Target) Is Nothing Or Target.Count > 1 Then Unload UserForm1 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
'основная процедура, выполняющая выделение 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("A2:AB1000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate End Sub
Сложно судить, без приложенного файла примера, но попробую предположить, что Вы записали макросы событий не в модули разных листов - каждый из ни должен быть записан в код именно того листа, события с которого он обрабатывает
Сложно судить, без приложенного файла примера, но попробую предположить, что Вы записали макросы событий не в модули разных листов - каждый из ни должен быть записан в код именно того листа, события с которого он обрабатываетМВТ
У Вас два макроса с одинаковыми названиями в модуле одного листа - так быть не может. Их надо объединить в один, примерно так, если я правильно понял [vba]
Код
'îñíîâíàÿ ïðîöåäóðà, âûïîëíÿþùàÿ âûäåëåíèå Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect([Q:Q], Target) Is Nothing Or Target.Count > 1 Then Unload UserForm1 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("A2:AB1000") 'àäðåñ ðàáî÷åãî äèàïàçîíà, â ïðåäåëàõ êîòîðîãî âèäíî âûäåëåíèå Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'ôîðìèðóåì êðåñòîîáðàçíûé äèàïàçîí è âûäåëÿåì Target.Activate End Sub
[/vba]
У Вас два макроса с одинаковыми названиями в модуле одного листа - так быть не может. Их надо объединить в один, примерно так, если я правильно понял [vba]
Код
'îñíîâíàÿ ïðîöåäóðà, âûïîëíÿþùàÿ âûäåëåíèå Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect([Q:Q], Target) Is Nothing Or Target.Count > 1 Then Unload UserForm1 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("A2:AB1000") 'àäðåñ ðàáî÷åãî äèàïàçîíà, â ïðåäåëàõ êîòîðîãî âèäíî âûäåëåíèå Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'ôîðìèðóåì êðåñòîîáðàçíûé äèàïàçîí è âûäåëÿåì Target.Activate End Sub
все равно ошибка. до этого побывала прописывать вот так вот:
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect([Q:Q], Target) Is Nothing Or Target.Count > 1 Then Unload UserForm1 End If
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("A2:AB1000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate End Sub
[/vba] тоже ошибка (
все равно ошибка. до этого побывала прописывать вот так вот:
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect([Q:Q], Target) Is Nothing Or Target.Count > 1 Then Unload UserForm1 End If
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("A2:AB1000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate End Sub
RAN, спасибо большое. теперь почти работает. ошибка теперь в том, что при включении макроса выделения крестообразного диапазона, таблица из второго макроса с поиском появляется при клике по любой ячейки, а должна только по столбцу Q.
RAN, спасибо большое. теперь почти работает. ошибка теперь в том, что при включении макроса выделения крестообразного диапазона, таблица из второго макроса с поиском появляется при клике по любой ячейки, а должна только по столбцу Q. Leika
[/vba] Выделяет все ячейки в строке, в том числе и столбец Q.
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim WorkRange As Range If Target.Cells.Count > 1 Then Unload UserForm1: Exit Sub 'если выделено больше 1 ячейки - выходим If Intersect([Q:Q], Target(1)) Is Nothing Then Unload UserForm1 If Coord_Selection = False Then Exit Sub 'если выделение выключено - выходим Application.ScreenUpdating = False Set WorkRange = Range("A2:AB1000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate End Sub
[/vba] Выделяет все ячейки в строке, в том числе и столбец Q.
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim WorkRange As Range If Target.Cells.Count > 1 Then Unload UserForm1: Exit Sub 'если выделено больше 1 ячейки - выходим If Intersect([Q:Q], Target(1)) Is Nothing Then Unload UserForm1 If Coord_Selection = False Then Exit Sub 'если выделение выключено - выходим Application.ScreenUpdating = False Set WorkRange = Range("A2:AB1000") 'адрес рабочего диапазона, в пределах которого видно выделение Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select 'формируем крестообразный диапазон и выделяем Target.Activate End Sub