Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Оформление границ ячеек макросом.
 
#1
07.10.2017 12:44:43
С BVA не дружу, поэтому прошу помощи.

Алгоритм действий следующий:
- Активируем ячейку В7 происходит закрашивание вертикальных и горизонтальных границ ячеек в диапазоне А7:J7
- Активируем ячейку В8 происходит закрашивание вертикальных и горизонтальных границ ячеек в диапазоне А8:J8
Подобные манипуляции происходят в строках с 7 по 300.

Файл таблицы во вложении, макросы там уже имеются, к ним надо добавить, описанное выше.
Изменено: bsi52 - 07.10.2017 14:12:18
 
 
 
#2
07.10.2017 12:53:53
Доброго времени, для примера ознакомьтесь с материалом
http://www.planetaexcel.ru/techniques/9/58/
Инженер не тот, кто все знает, а тот кто знает где найти ответ.
 
 
 
#3
07.10.2017 13:10:19
bsi52, ну вот зачем такой большой шрифт? Исправьте форматирование.
 
 
 
#4
07.10.2017 13:14:53
Этот материал мне уже когда-то попадался. Там про перекрестное выделение, а мне надо оформлять границы ячеек при добавлении записей в строках. Спасибо за информацию.
 
 
 
#5
07.10.2017 13:26:30
Может быть, удобнее так: сначала "врукопашить" данные, а потом выполнить макрос "сетка" для всей таблицы?
 
 
 
#6
07.10.2017 13:31:20
Так это надо будет кнопочку ставить или сочетание клавиш, а мне не хотелось бы так.  
 
 
 
#7
07.10.2017 13:31:35
bsi52, Вы мой #3 видели?
 
 
 
#8
07.10.2017 13:38:38
Вы же не для себя стараетесь!  :D
А юзеру-рукопашнику без разницы - какую инструкцию исполнять - с кнопочкой или без нее!
 
 
 
#9
07.10.2017 13:46:52
шрифт в первом сообщении сделайте по-меньше, не знаю как остальные, а лично я - пугаюсь больших букв!
вот макрос, который нарисует границы в ячейках А:J определенной строки, надеюсь найдете способ как его выполнять по мере необходимости
Код
Sub BordsAJ(r&)
  Dim b&
  For b = 7 To 12
    range("a" & r & ":j" & r).Borders(b).Weight = xlThin
  Next
End Sub
Изменено: Ігор Гончаренко - 07.10.2017 13:48:04
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#10
07.10.2017 14:04:17
Iгор спасибо за ответ, но я не знаю как его использовать в моём случае. Полагаю, что надо вклинить его в этот код
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Автонумерация
Range("A7:A" & Range("B" & Rows.Count).End(xlUp).Row).FormulaR1C1 = "=IF(RC2="""","""",MAX(R1C1:R[-1]C)+1)"
  'переключение раскладки
    Select Case Target.Column    ' в зависимости от номера столбца активной ячеки
        Case 2:    ' для столбца Полис (серия)
            ВключитьАнглийскуюРаскладку
        Case 3:    'на столбце Полис (номер) включаем русскую раскладку клавы и далее всё на русском
            ВключитьРусскуюРаскладку
        Case Else:    ' ничего не делаем (оставляем текущую раскладку)
    End Select
'перемещение курсора по TAB
  Set PrevCell(0) = PrevCell(1)
  Set PrevCell(1) = Target
  If PrevCell(0) Is Nothing Then Exit Sub
  If Target.Column = 1 Then Exit Sub
  EnableEvents = False
  If Target.Column = TabEnd + 1 Then
    If PrevCell(0).Address = Target.Offset(0, -1).Address Then Cells(Target.Row + 1, TabStart).Select
    Set PrevCell(1) = ActiveCell
  End If
  EnableEvents = True
End Sub
в моём файле. Но куда ?
Изменено: bsi52 - 07.10.2017 14:05:58
 
 
 
#11
07.10.2017 14:16:10
суть Вашего макроса во многом загадочна для меня... но все-таки
1. скопируйте макрос из # 9 в модуль листа (к своим макросам)
2. предположу, если после 17-й строки  Вашего примера (  EnableEvents = False) написать BordsAJ target.row, Вы получите желаемый результат
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#12
07.10.2017 14:19:30
В модуль требуемого листа:
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, [A7:J300]) Then _
    Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Borders.LineStyle = xlContinuous
End Sub
Чем шире угол зрения, тем он тупее.
 
 
 
#13
07.10.2017 14:37:02
Сергей,
у автора темы в модуле листа уже живет Private Sub Worksheet_SelectionChange(ByVal Target As Range) и даже что-то делает... боюсь, что две она не сможет "подружить"((
bsi52,
вместо этого BordsAJ target.row или если еще не успели, то просто между строками 17-18 Вашего примера
скопируйте это:
Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Borders.LineStyle = xlContinuous
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#14
07.10.2017 14:52:47
Я встречал ещё такую запись:
Код
Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Borders.LineStyle = True
 
 
 
#15
07.10.2017 15:16:27
Сделал всё как описано выше, но при открытии файла выскакивает ошибка (см. файл), потом при после ввода данных в столбце В не работает автонумерация (вместо цифр формула) в столбце А. Если пытаюсь удалить строки то опять ошибка RUN-time error 13 Type mismatch. Код в файле такой (прав добавил end If после 2-й строки т.к. ошибка выскакивала.)
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, [A7:J300]) Then
    Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Borders.LineStyle = xlContinuous
 End If
'Автонумерация
Range("A7:A" & Range("B" & Rows.Count).End(xlUp).Row).FormulaR1C1 = "=IF(RC2="""","""",MAX(R1C1:R[-1]C)+1)"
  'переключение раскладки клаватуры
    Select Case Target.Column    ' в зависимости от номера столбца активной ячеки
        Case 2:    ' для столбца Полис (серия)
            ВключитьАнглийскуюРаскладку
        Case 3:    'на столбце Полис (номер) включаем русскую раскладку клавы и далее всё на русском
            ВключитьРусскуюРаскладку
        Case Else:    ' ничего не делаем (оставляем текущую раскладку)
    End Select
'перемещение курсора по TAB
  Set PrevCell(0) = PrevCell(1)
  Set PrevCell(1) = Target
  If PrevCell(0) Is Nothing Then Exit Sub
  If Target.Column = 1 Then Exit Sub
  EnableEvents = False
  
  Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Borders.LineStyle = xlContinuous
  
  If Target.Column = TabEnd + 1 Then
    If PrevCell(0).Address = Target.Offset(0, -1).Address Then Cells(Target.Row + 1, TabStart).Select
    Set PrevCell(1) = ActiveCell
  End If
  
  EnableEvents = True
End Sub
Изменено: bsi52 - 07.10.2017 15:16:49
 
 
 
Страницы: 1
Наверх