Координатное выделение

[Uralmaster]

единственное что плохо при этом способе - когда форматируешь одну ячейку в центре - форматируются все в диапазоне где проходит координатное выделение; наверное это невозможно убрать по определению( или можно ????...)
+ с цветом выделения не решается вопрос
что хорошо - что не убирает исходное форматирование ячеек по цвету как в варианте http://www.programmersforum.ru/showthread.php?t=119806 пост5

[Uralmaster]

'rng = c & ":" & c & "," & r & ":" & r 'выделение горизонт-вертик 
'rng = c & "8:" & c & "5000, B" & r & ":G" & r 'выделение горизонт-вертик диапазон 
'rng = r & ":" & r 'оставить только горизонт. выделение 
'rng = c & ":" & c 'оставить только верт. выделение 
'rng = c & "8:" & c & "5000" 'оставить только верт. выделение 1 диапазон 
'rng = "B" & r & ":G" & r  'оставить только горизонт. выделение 1 диапазон 
rng = "B" & r & ":G" & r & "," & "J" & r & ":N" & r ' гор выд 2 диапазона BE JN

[Hugo121]

Можно временно/насовсем отключить эту фишку кнопкой. Или придумать горячие клавиши.

[Uralmaster]

If Target.Cells.Count > 1 Then Exit Sub 'макрос координатное выделение
Application.EnableEvents = False
Application.ScreenUpdating = False 'чтоб не моргало
    addr = ActiveCell.Address()
    x = Split(addr, "$")
    c = x(1)
    r = x(2)
Set rng = Intersect(Target, Range("B8:G500,K8:N500"))
    If rng Is Nothing Then Exit Sub
    rng = "B" & r & ":G" & r & "," & "K" & r & ":N" & r  ' горизонтальное выделение 2-х диапазонов BG KN по совету Hugo121
If Intersect(rng, Target) Is Nothing Then Exit Sub
    Range(rng).Select
    cll = c & r
    Range(cll).Activate
Application.EnableEvents = True
Application.ScreenUpdating = True 'восстанавливаем Screen 
End Sub

так получше будет

[R Dmitry]

Сообщение от Uralmaster

If Target.Cells.Count > 1 Then Exit Sub 'макрос координатное выделение
Application.EnableEvents = False
Application.ScreenUpdating = False 'чтоб не моргало
    addr = ActiveCell.Address()
    x = Split(addr, "$")
    c = x(1)
    r = x(2)
Set rng = Intersect(Target, Range("B8:G500,K8:N500"))
    If rng Is Nothing Then Exit Sub
    rng = "B" & r & ":G" & r & "," & "K" & r & ":N" & r  ' горизонтальное выделение 2-х диапазонов BG KN по совету Hugo121
If Intersect(rng, Target) Is Nothing Then Exit Sub
    Range(rng).Select
    cll = c & r
    Range(cll).Activate
Application.EnableEvents = True
Application.ScreenUpdating = True 'восстанавливаем Screen 
End Sub

так получше будет

я бы так не сказал
при событии exit sub у вас будет отключено и обновление экрана и все события

поэтому перед exit sub восстановите события и обновления экрана, либо используйте GOTO

[R Dmitry]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub 'макрос координатное выделение
Application.EnableEvents = False
Application.ScreenUpdating = False 'чтоб не моргало
    addr = ActiveCell.Address()
    x = Split(addr, "$")
    c = x(1)
    r = x(2)
Set Rng = Intersect(Target, Range("B8:G500,K8:N500"))
    If Rng Is Nothing Then GoTo end_err
    Rng = "B" & r & ":G" & r & "," & "K" & r & ":N" & r  ' горизонтальное выделение 2-х диапазонов BG KN по совету Hugo121
'If Intersect(Rng, Target) Is Nothing Then GoTo end_err
    Range(Rng).Select
    cll = c & r
    Range(cll).Activate
end_err:    Application.EnableEvents = True: Application.ScreenUpdating = True 'восстанавливаем Screen
End Sub

[Uralmaster]

да заметил такое благодарю за поправку