Всем доброго времени суток!!! В продолжении ЭТОЙ ТЕМЫ Макрос и таблица успешно работают, но у босса возникло желание, что бы на листах Октябрь и контроль выполнения графика форматирование столбцов A-D абсолютно совпадало. Своих знаний как сделать не хватает. Что добавит в уже готовый и рабочий макрос?
[vba]
Код
Dim r0 As Long, r1 As Long Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'При выделении любой ячейки листа, запоминайем 'номер последней строчки в толбце С r0 = 0 r0 = Cells(Rows.Count, "c").End(xlUp).Row End Sub Private Sub Worksheet_Change(ByVal Target As Range) 'При изменении любой ячейки листа, запоминайем 'номер последней строчки в толбце С и сравниваем 'его со старым значением r0 r1 = 0 r1 = Cells(Rows.Count, "c").End(xlUp).Row
If r1 < r0 Then 'если новое значение меньше предыдущего, значит строчек поубавилось :) rt = r0 - r1 'запоминаем сколько строчек удалили 'удаляем столько же строчек на листе контроль Sheets("контроль выполнения графика").Range(Target.Address).Offset(0).Resize(rt).Delete ElseIf r1 > r0 Then 'если новое значение больше предыдущего, значит строчки добавились rt = r1 - r0 'запоминаем сколько строчек вставили 'вставляем строчки на листе контроль Sheets("контроль выполнения графика").Range(Target.Address).Offset(0).Resize(rt).Insert Shift:=xlDown End If 'копируем значения из диапазона K6:FP1000 Set Rng = Intersect(Target, Range("O11:AQ" & r1)) If Not Rng Is Nothing Then 'на листе контроль, сдвигаемся на 1 строчку вверх и на 3 столбца вправо Sheets("контроль выполнения графика").Range(Rng.Address).Offset(0, 0).Value = Rng.Value End If 'копируем значения из диапазона A6:H1000 Set Rng = Intersect(Target, Range("A11:I" & r1)) If Not Rng Is Nothing Then Sheets("контроль выполнения графика").Range(Rng.Address).Offset(0).Value = Rng.Value End If End Sub
[/vba]
Всем доброго времени суток!!! В продолжении ЭТОЙ ТЕМЫ Макрос и таблица успешно работают, но у босса возникло желание, что бы на листах Октябрь и контроль выполнения графика форматирование столбцов A-D абсолютно совпадало. Своих знаний как сделать не хватает. Что добавит в уже готовый и рабочий макрос?
[vba]
Код
Dim r0 As Long, r1 As Long Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'При выделении любой ячейки листа, запоминайем 'номер последней строчки в толбце С r0 = 0 r0 = Cells(Rows.Count, "c").End(xlUp).Row End Sub Private Sub Worksheet_Change(ByVal Target As Range) 'При изменении любой ячейки листа, запоминайем 'номер последней строчки в толбце С и сравниваем 'его со старым значением r0 r1 = 0 r1 = Cells(Rows.Count, "c").End(xlUp).Row
If r1 < r0 Then 'если новое значение меньше предыдущего, значит строчек поубавилось :) rt = r0 - r1 'запоминаем сколько строчек удалили 'удаляем столько же строчек на листе контроль Sheets("контроль выполнения графика").Range(Target.Address).Offset(0).Resize(rt).Delete ElseIf r1 > r0 Then 'если новое значение больше предыдущего, значит строчки добавились rt = r1 - r0 'запоминаем сколько строчек вставили 'вставляем строчки на листе контроль Sheets("контроль выполнения графика").Range(Target.Address).Offset(0).Resize(rt).Insert Shift:=xlDown End If 'копируем значения из диапазона K6:FP1000 Set Rng = Intersect(Target, Range("O11:AQ" & r1)) If Not Rng Is Nothing Then 'на листе контроль, сдвигаемся на 1 строчку вверх и на 3 столбца вправо Sheets("контроль выполнения графика").Range(Rng.Address).Offset(0, 0).Value = Rng.Value End If 'копируем значения из диапазона A6:H1000 Set Rng = Intersect(Target, Range("A11:I" & r1)) If Not Rng Is Nothing Then Sheets("контроль выполнения графика").Range(Rng.Address).Offset(0).Value = Rng.Value End If End Sub
Игорь, привет! Можно в Worksheet_Change листа "Сентябрь" 7-ю снизу строку (после =========, его я написал, чтобы обозначить место) переписать так [vba]
Код
If Not Rng Is Nothing Then 'на листе контроль, сдвигаемся на 1 строчку вверх и на 3 столбца вправо '========================== Rng.Copy Sheets("контроль выполнения графика").Range(Rng.Address).Offset(0, 0) End If 'копируем значения из диапазона A6:H1000 Set Rng = Intersect(Target, Range("A11:I" & r1)) If Not Rng Is Nothing Then Sheets("контроль выполнения графика").Range(Rng.Address).Offset(0).Value = Rng.Value End If
[/vba] Но дело в том, что у тебя на листе "Контроль" при активации листа срабатывает макрос, красящий цифры в голубой цвет. Поэтому такой же формат все равно не получится. Если этот голубой тебе, конечно, так дорог
Добавлено Ну и вторую строку снизу тоже конечно Файл перевложил
======= Это если я правильно понял твой вопрос
Игорь, привет! Можно в Worksheet_Change листа "Сентябрь" 7-ю снизу строку (после =========, его я написал, чтобы обозначить место) переписать так [vba]
Код
If Not Rng Is Nothing Then 'на листе контроль, сдвигаемся на 1 строчку вверх и на 3 столбца вправо '========================== Rng.Copy Sheets("контроль выполнения графика").Range(Rng.Address).Offset(0, 0) End If 'копируем значения из диапазона A6:H1000 Set Rng = Intersect(Target, Range("A11:I" & r1)) If Not Rng Is Nothing Then Sheets("контроль выполнения графика").Range(Rng.Address).Offset(0).Value = Rng.Value End If
[/vba] Но дело в том, что у тебя на листе "Контроль" при активации листа срабатывает макрос, красящий цифры в голубой цвет. Поэтому такой же формат все равно не получится. Если этот голубой тебе, конечно, так дорог
Добавлено Ну и вторую строку снизу тоже конечно Файл перевложил
======= Это если я правильно понял твой вопрос_Boroda_
Привет!!! Саша немного не так. надо именно в столбцах A-D сохранять форматирование шрифтов. Ну там Жирный или Курсив. Уже сам сделал( потом увидел совет Андрея RAN ) Но вот интересует как это сделать в том макросе, который писал Ярослав
Привет!!! Саша немного не так. надо именно в столбцах A-D сохранять форматирование шрифтов. Ну там Жирный или Курсив. Уже сам сделал( потом увидел совет Андрея RAN ) Но вот интересует как это сделать в том макросе, который писал Ярослав китин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852