Форматирование новой строки по ранее заполненой - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Форматирование новой строки по ранее заполненой - Мир MS Excel

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Форматирование новой строки по ранее заполненой (Макросы/Sub)

Форматирование новой строки по ранее заполненой

Дата: Пятница, 08.05.2026, 11:48 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 70

Репутация: 0 ±

Замечаний: 0% ±

2013

Всем добра!
Уверен что даже для начинающих такой код будет простейшим но мои познания в VBA еще меньше (((

Имеется "журнал регистрации", постоянно растущий вниз мере заполнения новых строк (событий).
Задача следующая: при изменении значения в диапазоне столбцов А:P все атрибуты форматов ячейки в которой были введены любые значения - были бы назначены аналогично из ячейки строкой выше.
Пример - вводим какое угодно значение в ячейку F654 и после ЕNТЕR или ctrl+V в эту ячейку - она должна получить тот же формат что и в F653
Исключением должны быть первая и вторая строки листа а так же это правило должно работать если "протягивать" вниз.

Сообщение отредактировал Литр - Пятница, 08.05.2026, 13:43

Ответить

Дата: Суббота, 09.05.2026, 00:23 | Сообщение № 2

Группа: Проверенные

Ранг: Обитатель

Сообщений: 486

Репутация: 120 ±

Замечаний: 0% ±

MSO LTSC 2021 EN

Литр, Вечер добрый (а может быть и день или утро). Возможно я вас не правильно понял, но всё же пробуйте следуйщий код: [vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a           As Range
    Dim r           As Long

    On Error GoTo ExitHandler

    Dim rng         As Range
    Set rng = Intersect(Target, Me.Range("A:P"))
    If rng Is Nothing Then Exit Sub

    Application.EnableEvents = False

    For Each a In rng.Areas

        For r = Application.Max(3, a.Row) To a.Row + a.Rows.Count - 1
            Me.Range( _
                    Me.Cells(r - 1, a.Column), _
                    Me.Cells(r - 1, a.Column + a.Columns.Count - 1) _
                    ).Copy

            Me.Cells(r, a.Column).PasteSpecial xlPasteFormats
        Next r

    Next a

ExitHandler:

    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

[/vba]Данный код поместите в модуль листа где вы хотите

Цитата Литр, 08.05.2026 в 11:48, в сообщении № 1 (

)

при изменении значения в диапазоне столбцов А:P все атрибуты форматов ячейки в которой были введены любые значения - были бы назначены аналогично из ячейки строкой выше.

Пробуйте и дайте знать. Удачи.

Ученик.
Одесса - Украина

Ответить

Дата: Суббота, 09.05.2026, 16:17 | Сообщение № 3

Группа: Пользователи

Ранг: Участник

Сообщений: 70

Репутация: 0 ±

Замечаний: 0% ±

2013

MikeVol, хороший код.

Помоги соединить его с этим:

[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ExitHandler
    Application.EnableEvents = False
    Dim rng         As Range
    Set rng = Me.Range("F:P")
    If Target.CountLarge = 1 Then
        If Not Intersect(Target, rng) Is Nothing Then
            AutoFitRow Target
        End If
    End If
ExitHandler:
    Application.EnableEvents = True
    Dim i As Long
    If Target.Column = 4 Then
        i = Application.Match(Target.Value, Sheets("СПИСОК").Range("A1:A100"), 0)
         If i > 0 Then Range("E" & Target.Row).Value = Sheets("СПИСОК").Range("B" & i).Value
    End If
    If Not Intersect(Target, Columns("F:G")) Is Nothing Then
        If Range("F" & Target.Row) <> "" And Range("G" & Target.Row) <> "" Then Range("H" & Target.Row) = Range("F" & Target.Row).Value & " - " & Range("G" & Target.Row).Value
    End If
End Sub

[/vba]

Ответить

Дата: Суббота, 09.05.2026, 17:05 | Сообщение № 4

Группа: Проверенные

Ранг: Обитатель

Сообщений: 486

Репутация: 120 ±

Замечаний: 0% ±

MSO LTSC 2021 EN

Литр, Пробуйте:[vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a           As Range
    Dim r           As Long
    Dim i           As Variant

    On Error GoTo ExitHandler

    Dim rng         As Range
    Set rng = Intersect(Target, Me.Range("A:P"))

    Application.EnableEvents = False

    If Not rng Is Nothing Then

        For Each a In rng.Areas

            For r = Application.Max(3, a.Row) To a.Row + a.Rows.Count - 1
                Me.Range( _
                        Me.Cells(r - 1, a.Column), _
                        Me.Cells(r - 1, a.Column + a.Columns.Count - 1) _
                        ).Copy
                Me.Cells(r, a.Column).PasteSpecial xlPasteFormats
            Next r

        Next a

    End If

    If Target.CountLarge = 1 Then

        If Not Intersect(Target, Me.Range("F:P")) Is Nothing Then
            AutoFitRow Target
        End If

    End If

    If Target.CountLarge = 1 Then

        If Target.Column = 4 Then

            i = Application.Match(Target.Value, _
                    ThisWorkbook.Worksheets("СПИСОК").Range("A1:A100"), 0)

            If Not IsError(i) Then
                Me.Cells(Target.Row, 5).Value = _
                        ThisWorkbook.Worksheets("СПИСОК").Cells(i, 2).Value
            End If

        End If

    End If

    If Not Intersect(Target, Me.Columns("F:G")) Is Nothing Then

        With Me

            If Len(.Cells(Target.Row, 6).Value) > 0 And _
                    Len(.Cells(Target.Row, 7).Value) > 0 Then
                .Cells(Target.Row, 8).Value = _
                        .Cells(Target.Row, 6).Value & _
                        " - " & _
                        .Cells(Target.Row, 7).Value
            End If

        End With

    End If

ExitHandler:
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

Private Sub AutoFitRow(ByVal Target As Range)
    Target.EntireRow.AutoFit
End Sub

[/vba]

Литр, Пробуйте:[vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a           As Range
    Dim r           As Long
    Dim i           As Variant

    On Error GoTo ExitHandler

    Dim rng         As Range
    Set rng = Intersect(Target, Me.Range("A:P"))

    Application.EnableEvents = False

    If Not rng Is Nothing Then

        For Each a In rng.Areas

            For r = Application.Max(3, a.Row) To a.Row + a.Rows.Count - 1
                Me.Range( _
                        Me.Cells(r - 1, a.Column), _
                        Me.Cells(r - 1, a.Column + a.Columns.Count - 1) _
                        ).Copy
                Me.Cells(r, a.Column).PasteSpecial xlPasteFormats
            Next r

        Next a

    End If

    If Target.CountLarge = 1 Then

        If Not Intersect(Target, Me.Range("F:P")) Is Nothing Then
            AutoFitRow Target
        End If

    End If

    If Target.CountLarge = 1 Then

        If Target.Column = 4 Then

            i = Application.Match(Target.Value, _
                    ThisWorkbook.Worksheets("СПИСОК").Range("A1:A100"), 0)

            If Not IsError(i) Then
                Me.Cells(Target.Row, 5).Value = _
                        ThisWorkbook.Worksheets("СПИСОК").Cells(i, 2).Value
            End If

        End If

    End If

    If Not Intersect(Target, Me.Columns("F:G")) Is Nothing Then

        With Me

            If Len(.Cells(Target.Row, 6).Value) > 0 And _
                    Len(.Cells(Target.Row, 7).Value) > 0 Then
                .Cells(Target.Row, 8).Value = _
                        .Cells(Target.Row, 6).Value & _
                        " - " & _
                        .Cells(Target.Row, 7).Value
            End If

        End With

    End If

ExitHandler:
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

Private Sub AutoFitRow(ByVal Target As Range)
    Target.EntireRow.AutoFit
End Sub

Ученик.
Одесса - Украина

Ответить

СообщениеЛитр, Пробуйте:[vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a           As Range
    Dim r           As Long
    Dim i           As Variant

    On Error GoTo ExitHandler

    Dim rng         As Range
    Set rng = Intersect(Target, Me.Range("A:P"))

    Application.EnableEvents = False

    If Not rng Is Nothing Then

        For Each a In rng.Areas

            For r = Application.Max(3, a.Row) To a.Row + a.Rows.Count - 1
                Me.Range( _
                        Me.Cells(r - 1, a.Column), _
                        Me.Cells(r - 1, a.Column + a.Columns.Count - 1) _
                        ).Copy
                Me.Cells(r, a.Column).PasteSpecial xlPasteFormats
            Next r

        Next a

    End If

    If Target.CountLarge = 1 Then

        If Not Intersect(Target, Me.Range("F:P")) Is Nothing Then
            AutoFitRow Target
        End If

    End If

    If Target.CountLarge = 1 Then

        If Target.Column = 4 Then

            i = Application.Match(Target.Value, _
                    ThisWorkbook.Worksheets("СПИСОК").Range("A1:A100"), 0)

            If Not IsError(i) Then
                Me.Cells(Target.Row, 5).Value = _
                        ThisWorkbook.Worksheets("СПИСОК").Cells(i, 2).Value
            End If

        End If

    End If

    If Not Intersect(Target, Me.Columns("F:G")) Is Nothing Then

        With Me

            If Len(.Cells(Target.Row, 6).Value) > 0 And _
                    Len(.Cells(Target.Row, 7).Value) > 0 Then
                .Cells(Target.Row, 8).Value = _
                        .Cells(Target.Row, 6).Value & _
                        " - " & _
                        .Cells(Target.Row, 7).Value
            End If

        End With

    End If

ExitHandler:
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

Private Sub AutoFitRow(ByVal Target As Range)
    Target.EntireRow.AutoFit
End Sub

[/vba]

Автор - MikeVol
Дата добавления - 09.05.2026 в 17:05

Дата: Вторник, 12.05.2026, 12:35 | Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 70

Репутация: 0 ±

Замечаний: 0% ±

2013

MikeVol, проверил, работает. Но непривычно когда после ввода значений в ячейку, выделенной остается та которую меняли.
Как бы исправить что бы по привычке после Enter выделялась ячейка рядом ниже. В остальном Ок.

Только у меня какая то дичь с форматами. Возможно что это из-за того что я на вкладке "Стили" удалил все форматы? пытаюсь их вернуть командой "объединить стили"

Ответить

Дата: Вторник, 12.05.2026, 17:05 | Сообщение № 6

Группа: Проверенные

Ранг: Обитатель

Сообщений: 486

Репутация: 120 ±

Замечаний: 0% ±

MSO LTSC 2021 EN

Цитата Литр, 12.05.2026 в 12:35, в сообщении № 5 (

)

что бы по привычке после Enter выделялась ячейка рядом ниж

Ок, сделайте небольшую правку в коде: [vba]

Код

ExitHandler:
    Application.CutCopyMode = False
    Application.EnableEvents = True

    If Target.CountLarge = 1 Then
        Application.Goto Target.Offset(1), False
    End If

End Sub

[/vba]Не проверял, проверьте сами. Удачи.

Ученик.
Одесса - Украина

Сообщение отредактировал MikeVol - Вторник, 12.05.2026, 17:06

Ответить

Дата: Среда, 13.05.2026, 13:21 | Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 70

Репутация: 0 ±

Замечаний: 0% ±

2013

MikeVol, Да, как бы норм но не совсем.

Попытаюсь объяснить: кроме enter или ctrl+V некоторые мои юзеры, ввод значения в ячейку заканчивают используя стрелки или даже переводят мышью на другую ячейку.

Естественно они в недоумении почему выделяется не та ячейка которую они хотели. Есть возможность подправить макрос так что бы если enter то вниз; стрелка - то в зависимсти от стрелки (вверх, лево, право, низ); ctrl+V то остается в ней; ну и если мышью то соответстенно.... То есть не зависимо от того как заканчивается ввод данных в ячейку, она принимает формат из вышестоящей.
И вот еще что: не работает это правило когда отрабатывают функции в колонках 5 и 8.

Спасибо заранее

Ответить

Дата: Четверг, 14.05.2026, 17:13 | Сообщение № 8

Группа: Проверенные

Ранг: Обитатель

Сообщений: 486

Репутация: 120 ±

Замечаний: 0% ±

MSO LTSC 2021 EN

??? [vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a           As Range
    Dim r           As Long
    Dim i           As Variant

    On Error GoTo ExitHandler

    Dim rng         As Range
    Set rng = Intersect(Target, Me.Range("A:P"))

    Application.EnableEvents = False

    If Not rng Is Nothing Then

        For Each a In rng.Areas

            For r = Application.Max(3, a.Row) To a.Row + a.Rows.Count - 1
                Me.Range( _
                        Me.Cells(r - 1, a.Column), _
                        Me.Cells(r - 1, a.Column + a.Columns.Count - 1) _
                        ).Copy
                Me.Cells(r, a.Column).PasteSpecial xlPasteFormats
            Next r

        Next a

    End If

    If Target.CountLarge = 1 Then

        If Not Intersect(Target, Me.Range("F:P")) Is Nothing Then
            Target.EntireRow.AutoFit
        End If

    End If

    If Target.CountLarge = 1 Then

        If Target.Column = 4 Then

            i = Application.Match(Target.Value, _
                    ThisWorkbook.Worksheets("СПИСОК").Range("A1:A100"), 0)

            If Not IsError(i) Then

                With Me.Cells(Target.Row, 5)
                    .Value = ThisWorkbook.Worksheets("СПИСОК").Cells(i, 2).Value

                    .Offset(-1).Copy
                    .PasteSpecial xlPasteFormats
                End With

            End If

        End If

    End If

    If Not Intersect(Target, Me.Columns("F:G")) Is Nothing Then

        With Me.Cells(Target.Row, 8)

            If Len(Me.Cells(Target.Row, 6).Value) > 0 And _
                    Len(Me.Cells(Target.Row, 7).Value) > 0 Then
                .Value = _
                        Me.Cells(Target.Row, 6).Value & _
                        " - " & _
                        Me.Cells(Target.Row, 7).Value

                .Offset(-1).Copy
                .PasteSpecial xlPasteFormats
            End If

        End With

        Me.Rows(Target.Row).AutoFit
    End If

ExitHandler:
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

[/vba]

??? [vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a           As Range
    Dim r           As Long
    Dim i           As Variant

    On Error GoTo ExitHandler

    Dim rng         As Range
    Set rng = Intersect(Target, Me.Range("A:P"))

    Application.EnableEvents = False

    If Not rng Is Nothing Then

        For Each a In rng.Areas

            For r = Application.Max(3, a.Row) To a.Row + a.Rows.Count - 1
                Me.Range( _
                        Me.Cells(r - 1, a.Column), _
                        Me.Cells(r - 1, a.Column + a.Columns.Count - 1) _
                        ).Copy
                Me.Cells(r, a.Column).PasteSpecial xlPasteFormats
            Next r

        Next a

    End If

    If Target.CountLarge = 1 Then

        If Not Intersect(Target, Me.Range("F:P")) Is Nothing Then
            Target.EntireRow.AutoFit
        End If

    End If

    If Target.CountLarge = 1 Then

        If Target.Column = 4 Then

            i = Application.Match(Target.Value, _
                    ThisWorkbook.Worksheets("СПИСОК").Range("A1:A100"), 0)

            If Not IsError(i) Then

                With Me.Cells(Target.Row, 5)
                    .Value = ThisWorkbook.Worksheets("СПИСОК").Cells(i, 2).Value

                    .Offset(-1).Copy
                    .PasteSpecial xlPasteFormats
                End With

            End If

        End If

    End If

    If Not Intersect(Target, Me.Columns("F:G")) Is Nothing Then

        With Me.Cells(Target.Row, 8)

            If Len(Me.Cells(Target.Row, 6).Value) > 0 And _
                    Len(Me.Cells(Target.Row, 7).Value) > 0 Then
                .Value = _
                        Me.Cells(Target.Row, 6).Value & _
                        " - " & _
                        Me.Cells(Target.Row, 7).Value

                .Offset(-1).Copy
                .PasteSpecial xlPasteFormats
            End If

        End With

        Me.Rows(Target.Row).AutoFit
    End If

ExitHandler:
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

Ученик.
Одесса - Украина

Ответить

Сообщение??? [vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a           As Range
    Dim r           As Long
    Dim i           As Variant

    On Error GoTo ExitHandler

    Dim rng         As Range
    Set rng = Intersect(Target, Me.Range("A:P"))

    Application.EnableEvents = False

    If Not rng Is Nothing Then

        For Each a In rng.Areas

            For r = Application.Max(3, a.Row) To a.Row + a.Rows.Count - 1
                Me.Range( _
                        Me.Cells(r - 1, a.Column), _
                        Me.Cells(r - 1, a.Column + a.Columns.Count - 1) _
                        ).Copy
                Me.Cells(r, a.Column).PasteSpecial xlPasteFormats
            Next r

        Next a

    End If

    If Target.CountLarge = 1 Then

        If Not Intersect(Target, Me.Range("F:P")) Is Nothing Then
            Target.EntireRow.AutoFit
        End If

    End If

    If Target.CountLarge = 1 Then

        If Target.Column = 4 Then

            i = Application.Match(Target.Value, _
                    ThisWorkbook.Worksheets("СПИСОК").Range("A1:A100"), 0)

            If Not IsError(i) Then

                With Me.Cells(Target.Row, 5)
                    .Value = ThisWorkbook.Worksheets("СПИСОК").Cells(i, 2).Value

                    .Offset(-1).Copy
                    .PasteSpecial xlPasteFormats
                End With

            End If

        End If

    End If

    If Not Intersect(Target, Me.Columns("F:G")) Is Nothing Then

        With Me.Cells(Target.Row, 8)

            If Len(Me.Cells(Target.Row, 6).Value) > 0 And _
                    Len(Me.Cells(Target.Row, 7).Value) > 0 Then
                .Value = _
                        Me.Cells(Target.Row, 6).Value & _
                        " - " & _
                        Me.Cells(Target.Row, 7).Value

                .Offset(-1).Copy
                .PasteSpecial xlPasteFormats
            End If

        End With

        Me.Rows(Target.Row).AutoFit
    End If

ExitHandler:
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

[/vba]

Автор - MikeVol
Дата добавления - 14.05.2026 в 17:13

Дата: Понедельник, 18.05.2026, 09:05 | Сообщение № 9

Группа: Пользователи

Ранг: Участник

Сообщений: 70

Репутация: 0 ±

Замечаний: 0% ±

2013

MikeVol, проверил вариант из Сообщение № 8
не корректно работает, снова после присвоения формата выделяется эта же ячейка, а нужно:
если enter то вниз;
стрелка - то в зависимсти от стрелки (вверх, лево, право, низ);
ctrl+V то остается в ней;
если мышью то соответственно ячейка по клику мышью

Ответить

Дата: Понедельник, 18.05.2026, 15:24 | Сообщение № 10

Группа: Проверенные

Ранг: Обитатель

Сообщений: 486

Репутация: 120 ±

Замечаний: 0% ±

MSO LTSC 2021 EN

Литр, Идеи мои кончились.

Ученик.
Одесса - Украина

Ответить

Дата: Вторник, 09.06.2026, 16:14 | Сообщение № 11

Группа: Пользователи

Ранг: Участник

Сообщений: 70

Репутация: 0 ±

Замечаний: 0% ±

2013

Подниму тему поменяв условия задачи:

При вводе данных в столбцы B и С - (2 и 3)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop

При вводе данных в столбцы 4-8, 10-12, 14-16
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop

В 9 и 13 столбце:
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop

Ответить

Дата: Вторник, 09.06.2026, 23:14 | Сообщение № 12

Группа: Проверенные

Ранг: Ветеран

Сообщений: 638

Репутация: 142 ±

Замечаний: 0% ±

365

Литр Доброй... наверно еще пренос по словам надо?

К сообщению приложен файл: cheto.xlsm (16.8 Kb)

Ответить

Дата: Среда, 10.06.2026, 12:39 | Сообщение № 13

Группа: Пользователи

Ранг: Участник

Сообщений: 70

Репутация: 0 ±

Замечаний: 0% ±

2013

cmivadwot, да, работает
На листе есть еще несколько макросов, нужно их объединить. У меня не получается

[vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo SafeExit
    If Target Is Nothing Then Exit Sub
    If Target.CountLarge > 1 Then GoTo SafeExit
    Application.EnableEvents = False

    Dim rng         As Range
    Set rng = Me.Range("B2:P5000")

    If Not Intersect(Target, rng) Is Nothing Then

        If Not IsDate(Target.Value) Then

            If VarType(Target.Value) = vbString Then
                Target.Value = UCase$(CStr(Target.Value))
            End If

        End If

        AutoFitRow Target
    End If

    If Target.Column = 4 Then

        Dim i       As Variant
        i = Application.Match(Target.Value, _
                Sheets("СПИСОК").Range("A1:A100"), 0)

        If Not IsError(i) Then
            Me.Cells(Target.Row, "E").Value = _
                    Sheets("СПИСОК").Cells(i, "B").Value
        End If

    End If

    If Not Intersect(Target, Me.Columns("F:G")) Is Nothing Then

        If Len(Me.Cells(Target.Row, "F").Value) > 0 And _
                Len(Me.Cells(Target.Row, "G").Value) > 0 Then
            Me.Cells(Target.Row, "H").Value = _
                    Me.Cells(Target.Row, "F").Value & " - " & _
                    Me.Cells(Target.Row, "G").Value
        End If

    End If

SafeExit:
    Application.EnableEvents = True
End Sub

Private Sub AutoFitRow(ByVal cell As Range)
    Dim r           As Long
    r = cell.Row

    With Me.Rows(r)
        .AutoFit

        If .RowHeight < 30 Then .RowHeight = 30
        If .RowHeight > 120 Then .RowHeight = 120
    End With

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Column = 13 Then
        Application.CutCopyMode = False
    End If

End Sub

[/vba]

cmivadwot, да, работает
На листе есть еще несколько макросов, нужно их объединить. У меня не получается

[vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo SafeExit
    If Target Is Nothing Then Exit Sub
    If Target.CountLarge > 1 Then GoTo SafeExit
    Application.EnableEvents = False

    Dim rng         As Range
    Set rng = Me.Range("B2:P5000")

    If Not Intersect(Target, rng) Is Nothing Then

        If Not IsDate(Target.Value) Then

            If VarType(Target.Value) = vbString Then
                Target.Value = UCase$(CStr(Target.Value))
            End If

        End If

        AutoFitRow Target
    End If

    If Target.Column = 4 Then

        Dim i       As Variant
        i = Application.Match(Target.Value, _
                Sheets("СПИСОК").Range("A1:A100"), 0)

        If Not IsError(i) Then
            Me.Cells(Target.Row, "E").Value = _
                    Sheets("СПИСОК").Cells(i, "B").Value
        End If

    End If

    If Not Intersect(Target, Me.Columns("F:G")) Is Nothing Then

        If Len(Me.Cells(Target.Row, "F").Value) > 0 And _
                Len(Me.Cells(Target.Row, "G").Value) > 0 Then
            Me.Cells(Target.Row, "H").Value = _
                    Me.Cells(Target.Row, "F").Value & " - " & _
                    Me.Cells(Target.Row, "G").Value
        End If

    End If

SafeExit:
    Application.EnableEvents = True
End Sub

Private Sub AutoFitRow(ByVal cell As Range)
    Dim r           As Long
    r = cell.Row

    With Me.Rows(r)
        .AutoFit

        If .RowHeight < 30 Then .RowHeight = 30
        If .RowHeight > 120 Then .RowHeight = 120
    End With

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Column = 13 Then
        Application.CutCopyMode = False
    End If

End Sub

[/vba]

Литр

Ответить

Сообщениеcmivadwot, да, работает
На листе есть еще несколько макросов, нужно их объединить. У меня не получается

[vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo SafeExit
    If Target Is Nothing Then Exit Sub
    If Target.CountLarge > 1 Then GoTo SafeExit
    Application.EnableEvents = False

    Dim rng         As Range
    Set rng = Me.Range("B2:P5000")

    If Not Intersect(Target, rng) Is Nothing Then

        If Not IsDate(Target.Value) Then

            If VarType(Target.Value) = vbString Then
                Target.Value = UCase$(CStr(Target.Value))
            End If

        End If

        AutoFitRow Target
    End If

    If Target.Column = 4 Then

        Dim i       As Variant
        i = Application.Match(Target.Value, _
                Sheets("СПИСОК").Range("A1:A100"), 0)

        If Not IsError(i) Then
            Me.Cells(Target.Row, "E").Value = _
                    Sheets("СПИСОК").Cells(i, "B").Value
        End If

    End If

    If Not Intersect(Target, Me.Columns("F:G")) Is Nothing Then

        If Len(Me.Cells(Target.Row, "F").Value) > 0 And _
                Len(Me.Cells(Target.Row, "G").Value) > 0 Then
            Me.Cells(Target.Row, "H").Value = _
                    Me.Cells(Target.Row, "F").Value & " - " & _
                    Me.Cells(Target.Row, "G").Value
        End If

    End If

SafeExit:
    Application.EnableEvents = True
End Sub

Private Sub AutoFitRow(ByVal cell As Range)
    Dim r           As Long
    r = cell.Row

    With Me.Rows(r)
        .AutoFit

        If .RowHeight < 30 Then .RowHeight = 30
        If .RowHeight > 120 Then .RowHeight = 120
    End With

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Column = 13 Then
        Application.CutCopyMode = False
    End If

End Sub

[/vba]

Автор - Литр
Дата добавления - 10.06.2026 в 12:39

Дата: Четверг, 11.06.2026, 00:36 | Сообщение № 14

Группа: Проверенные

Ранг: Ветеран

Сообщений: 638

Репутация: 142 ±

Замечаний: 0% ±

365

Литр, доброй..

К сообщению приложен файл: cheto2.xlsm (24.0 Kb)

Ответить

Дата: Четверг, 11.06.2026, 09:28 | Сообщение № 15

Группа: Пользователи

Ранг: Участник

Сообщений: 70

Репутация: 0 ±

Замечаний: 0% ±

2013

cmivadwot, просто класс!!! количество 'комментариев к макросу даже больше чем самого макро. С таким кодом можно изучать VBA. Огромное спасибо

Ответить

Форматирование новой строки по ранее заполненой (Макросы/Sub)

Страница 1 из 1
1

© 2010-2026 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!