Сохранение нумерации строк после сортировки - Мир MS Excel

Регистрация

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

= Мир MS Excel/Сохранение нумерации строк после сортировки - Мир MS Excel

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

Сохранение нумерации строк после сортировки (Формулы/Formulas)

Сохранение нумерации строк после сортировки

Дата: Понедельник, 14.07.2025, 17:07 | Сообщение № 1

Egider

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

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

Сообщений: 73

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

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

Excel 2016

Уважаемые форумчане, подскажите пожалуйста как сохранить нумерацию строк в таблице после сортировки. Нумерация идет не по порядку. Нужно чтобы при удалении какой либо строки она сохранялась и не пропадал удаленный номер. Файл прилагаю. СПАСИБО.

К сообщению приложен файл: 456.xls (26.5 Kb)

Пенсионер

Ответить

Дата: Понедельник, 14.07.2025, 17:44 | Сообщение № 2

Группа: Админы

Ранг: Местный житель

Сообщений: 16956

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

Замечаний: ±

2003; 2007; 2010; 2013 RUS

Нужна логика расстановки номеров

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

Дата: Понедельник, 14.07.2025, 17:50 | Сообщение № 3

Egider

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

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

Сообщений: 73

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

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

Excel 2016

Логика проста - по порядку, но независимо от размещения номеров в столбце, т.к сортировка идет по данным в столбце 1. Возможно ли это?

Пенсионер

Ответить

Дата: Понедельник, 14.07.2025, 18:32 | Сообщение № 4

Группа: Модераторы

Ранг: Старожил

Сообщений: 2125

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

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

Excel LTSC 2024 RUS

А что будет с номером 1 если удалены две строки? Он становится -1?

Ответить

Дата: Понедельник, 14.07.2025, 18:42 | Сообщение № 5

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

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

Сообщений: 457

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

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

MSO LTSC 2021 EN

Egider, Доброго времени суток. Про

Цитата Egider, 14.07.2025 в 17:07, в сообщении № 1 (

)

после сортировки

вообще ничего не понял. Написал как понял вас:

[vba]

Код

Option Explicit

Sub ОбновитьНумерациюПослеУдаления()
    Dim i           As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        If ActiveCell.Row < 2 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("C2:D" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 1

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 2)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To 2)

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                newArr(outIndex, 1) = arr(i, 1)

                If IsNumeric(arr(i, 2)) And arr(i, 2) > удалённоеЧисло Then
                    newArr(outIndex, 2) = arr(i, 2) - 1
                Else
                    newArr(outIndex, 2) = arr(i, 2)
                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Range("C2:D" & lastRow).ClearContents
        .Range("C2").Resize(UBound(newArr, 1), 2).Value = newArr
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("C2:D" & lastRow).ClearContents
            .Range("C2").Resize(UBound(arr, 1), 2).Value = arr
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
End Sub

[/vba]

Суть такова кода: Ставновитесь на ячейку в любой колонке (C:D), запускаете макрос. Он сам удалит строку выбранную и пронумерует снова.
Может чем поможет. Удачи.

Egider, Доброго времени суток. Про

Цитата Egider, 14.07.2025 в 17:07, в сообщении № 1 (

)

после сортировки

вообще ничего не понял. Написал как понял вас:

[vba]

Код

Option Explicit

Sub ОбновитьНумерациюПослеУдаления()
    Dim i           As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        If ActiveCell.Row < 2 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("C2:D" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 1

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 2)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To 2)

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                newArr(outIndex, 1) = arr(i, 1)

                If IsNumeric(arr(i, 2)) And arr(i, 2) > удалённоеЧисло Then
                    newArr(outIndex, 2) = arr(i, 2) - 1
                Else
                    newArr(outIndex, 2) = arr(i, 2)
                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Range("C2:D" & lastRow).ClearContents
        .Range("C2").Resize(UBound(newArr, 1), 2).Value = newArr
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("C2:D" & lastRow).ClearContents
            .Range("C2").Resize(UBound(arr, 1), 2).Value = arr
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
End Sub

[/vba]

Суть такова кода: Ставновитесь на ячейку в любой колонке (C:D), запускаете макрос. Он сам удалит строку выбранную и пронумерует снова.
Может чем поможет. Удачи.MikeVol

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

Сообщение отредактировал MikeVol - Понедельник, 14.07.2025, 18:44

Ответить

СообщениеEgider, Доброго времени суток. Про

Цитата Egider, 14.07.2025 в 17:07, в сообщении № 1 (

)

после сортировки

вообще ничего не понял. Написал как понял вас:

[vba]

Код

Option Explicit

Sub ОбновитьНумерациюПослеУдаления()
    Dim i           As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        If ActiveCell.Row < 2 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("C2:D" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 1

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 2)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To 2)

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                newArr(outIndex, 1) = arr(i, 1)

                If IsNumeric(arr(i, 2)) And arr(i, 2) > удалённоеЧисло Then
                    newArr(outIndex, 2) = arr(i, 2) - 1
                Else
                    newArr(outIndex, 2) = arr(i, 2)
                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Range("C2:D" & lastRow).ClearContents
        .Range("C2").Resize(UBound(newArr, 1), 2).Value = newArr
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("C2:D" & lastRow).ClearContents
            .Range("C2").Resize(UBound(arr, 1), 2).Value = arr
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
End Sub

[/vba]

Суть такова кода: Ставновитесь на ячейку в любой колонке (C:D), запускаете макрос. Он сам удалит строку выбранную и пронумерует снова.
Может чем поможет. Удачи.

Автор - MikeVol
Дата добавления - 14.07.2025 в 18:42

Дата: Понедельник, 14.07.2025, 19:59 | Сообщение № 6

Egider

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

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

Сообщений: 73

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

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

Excel 2016

Уважаемый MikeVol, большое Вам спасибо. Вы все правильно поняли, работает.

[moder]Если Вам помогли и Вы хотите сказать "Спасибо" форумчанину помогшему Вам - нажмите "+" напротив надписи "Репутация" в любом его посте.[/moder]

Пенсионер

Ответить

Дата: Вторник, 15.07.2025, 00:43 | Сообщение № 7

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

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

Сообщений: 457

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

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

MSO LTSC 2021 EN

Egider, Упс, только сейчас заметил свою ошибку. В блоке CleanExit: верните обратно Автоматический пересчёт формул. Данную строку:[vba]

Код

.Calculation = xlCalculationManual

[/vba] замените на:[vba]

Код

.Calculation = xlCalculationAutomatic

[/vba]Извините, мой косяк. Удачи.

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

Сообщение отредактировал MikeVol - Вторник, 15.07.2025, 00:44

Ответить

Дата: Вторник, 15.07.2025, 17:14 | Сообщение № 8

Egider

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

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

Сообщений: 73

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

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

Excel 2016

Уважаемый MikeVol, извиняюсь, но если необходимо удалять всю строку, а не две соседние ячейки, то какие изменения необходимо произвести? Изменить только диапазон или еще что?

Пенсионер

Ответить

Дата: Вторник, 15.07.2025, 23:51 | Сообщение № 9

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

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

Сообщений: 457

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

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

MSO LTSC 2021 EN

Цитата Egider, 15.07.2025 в 17:14, в сообщении № 8 (

)

если необходимо удалять всю строку

Необходимо знать границы диапазона вашей таблицы. Не зная границ таблицы могу предложить вариант изменить пару строк в коде:

[vba]

Код

Option Explicit

Sub ОбновитьНумерациюПослеУдаления_v2()
    Dim i           As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        If ActiveCell.Row < 2 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("C2:D" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 1

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 2)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To 2)

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                newArr(outIndex, 1) = arr(i, 1)

                If IsNumeric(arr(i, 2)) And arr(i, 2) > удалённоеЧисло Then
                    newArr(outIndex, 2) = arr(i, 2) - 1
                Else
                    newArr(outIndex, 2) = arr(i, 2)
                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Rows(ActiveCell.Row).ClearContents
        '        .Range("C2:D" & lastRow).ClearContents
        .Range("C2").Resize(UBound(newArr, 1), 2).Value = newArr
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("C2:D" & lastRow).ClearContents
            .Range("C2").Resize(UBound(arr, 1), 2).Value = arr
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
End Sub

[/vba]

Но данный код затронет целиком всю строку, что не есть хорошо если у вас правее вашей таблицы есть ещё какие-то данные. Он очистит и те данные. Будьте аккуратнее или дайте пример файла где будет виден ваш диапазон. Удачи.

Цитата Egider, 15.07.2025 в 17:14, в сообщении № 8 (

)

если необходимо удалять всю строку

Необходимо знать границы диапазона вашей таблицы. Не зная границ таблицы могу предложить вариант изменить пару строк в коде:

[vba]

Код

Option Explicit

Sub ОбновитьНумерациюПослеУдаления_v2()
    Dim i           As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        If ActiveCell.Row < 2 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("C2:D" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 1

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 2)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To 2)

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                newArr(outIndex, 1) = arr(i, 1)

                If IsNumeric(arr(i, 2)) And arr(i, 2) > удалённоеЧисло Then
                    newArr(outIndex, 2) = arr(i, 2) - 1
                Else
                    newArr(outIndex, 2) = arr(i, 2)
                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Rows(ActiveCell.Row).ClearContents
        '        .Range("C2:D" & lastRow).ClearContents
        .Range("C2").Resize(UBound(newArr, 1), 2).Value = newArr
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("C2:D" & lastRow).ClearContents
            .Range("C2").Resize(UBound(arr, 1), 2).Value = arr
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
End Sub

[/vba]

Но данный код затронет целиком всю строку, что не есть хорошо если у вас правее вашей таблицы есть ещё какие-то данные. Он очистит и те данные. Будьте аккуратнее или дайте пример файла где будет виден ваш диапазон. Удачи.MikeVol

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

Сообщение отредактировал MikeVol - Среда, 16.07.2025, 00:59

Ответить

Сообщение

Цитата Egider, 15.07.2025 в 17:14, в сообщении № 8 (

)

если необходимо удалять всю строку

Необходимо знать границы диапазона вашей таблицы. Не зная границ таблицы могу предложить вариант изменить пару строк в коде:

[vba]

Код

Option Explicit

Sub ОбновитьНумерациюПослеУдаления_v2()
    Dim i           As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        If ActiveCell.Row < 2 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("C2:D" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 1

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 2)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To 2)

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                newArr(outIndex, 1) = arr(i, 1)

                If IsNumeric(arr(i, 2)) And arr(i, 2) > удалённоеЧисло Then
                    newArr(outIndex, 2) = arr(i, 2) - 1
                Else
                    newArr(outIndex, 2) = arr(i, 2)
                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Rows(ActiveCell.Row).ClearContents
        '        .Range("C2:D" & lastRow).ClearContents
        .Range("C2").Resize(UBound(newArr, 1), 2).Value = newArr
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("C2:D" & lastRow).ClearContents
            .Range("C2").Resize(UBound(arr, 1), 2).Value = arr
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
End Sub

[/vba]

Но данный код затронет целиком всю строку, что не есть хорошо если у вас правее вашей таблицы есть ещё какие-то данные. Он очистит и те данные. Будьте аккуратнее или дайте пример файла где будет виден ваш диапазон. Удачи.

Автор - MikeVol
Дата добавления - 15.07.2025 в 23:51

Дата: Среда, 16.07.2025, 13:03 | Сообщение № 10

Egider

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

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

Сообщений: 73

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

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

Excel 2016

Уважаемый MikeVol, используя Ваши данные хотел внести изменения в таблицу. Но не получается, не могу добиться желаемого. Поэтому прошу еще раз взглянуть на мою таблицу и подсказать, можно ли сделать так, чтобы нумерация сохранялась даже если она идет не по порядку. Нужно чтобы после удаления строки нумерация сохранялась не нарушая порядка расположения строк после сортировки. В прилагаемом файле указаны границы таблицы "А4:АВ". Вариант 1 подходит, но нужно изменить диапазон и добиться удаления выбранной в колонке АВ строки.

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

Пенсионер

Сообщение отредактировал Egider - Среда, 16.07.2025, 16:26

Ответить

Дата: Среда, 16.07.2025, 13:44 | Сообщение № 11

Группа: Друзья

Ранг: Экселист

Сообщений: 9185

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

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

Excel 2010

вариант
[vba]

Код

Sub u_127()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "d").End(xlUp).Row
    Dim arr()
    For b = 4 To a
        c = Evaluate("MATCH(" & Range("d" & b).Value & ",SMALL(D4:D" & a & ",ROW(D4:D" & a & ")-3),)")
        ReDim Preserve arr(b - 4)
        arr(b - 4) = c
    Next
    For d = 4 To a
        Range("d" & d) = arr(d - 4)
    Next
    Application.ScreenUpdating = True
End Sub

[/vba]

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

ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Среда, 16.07.2025, 14:08

Ответить

Дата: Среда, 16.07.2025, 16:38 | Сообщение № 12

Egider

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

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

Сообщений: 73

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

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

Excel 2016

Что-то не работает, строка не удаляется и после первого нажатия все стопориться?

Пенсионер

Ответить

Дата: Среда, 16.07.2025, 16:57 | Сообщение № 13

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

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

Сообщений: 457

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

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

MSO LTSC 2021 EN

Egider, По какой колонке необходимо сохранить нумерацию, колонка D или колонка AA?

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

Ответить

Дата: Среда, 16.07.2025, 17:10 | Сообщение № 14

Egider

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

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

Сообщений: 73

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

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

Excel 2016

По колонке АА, а выбирать строку в колонке АВ.

Пенсионер

Ответить

Дата: Среда, 16.07.2025, 17:15 | Сообщение № 15

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

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

Сообщений: 457

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

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

MSO LTSC 2021 EN

Egider, Но удалять необходимо всю строку с диапазоном A:AB?

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

Ответить

Дата: Среда, 16.07.2025, 17:24 | Сообщение № 16

Egider

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

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

Сообщений: 73

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

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

Excel 2016

Да. Удаляется вся строка

Пенсионер

Сообщение отредактировал Egider - Среда, 16.07.2025, 17:52

Ответить

Дата: Среда, 16.07.2025, 18:11 | Сообщение № 17

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

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

Сообщений: 457

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

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

MSO LTSC 2021 EN

Egider, Может кто сможет оптимальнее но как умею:

[vba]

Код

Option Explicit

Sub Вариант3()
    Dim i As Long, targetRow As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "AB").End(xlUp).Row

        If ActiveCell.Row < 4 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("A4:AB" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 3

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 27)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To UBound(arr, 2))

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                Dim j As Long

                For j = 1 To UBound(arr, 2)
                    newArr(outIndex, j) = arr(i, j)
                Next j

                If IsNumeric(arr(i, 27)) Then

                    If arr(i, 27) > удалённоеЧисло Then
                        newArr(outIndex, 27) = arr(i, 27) - 1
                    Else
                        newArr(outIndex, 27) = arr(i, 27)
                    End If

                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Range("A4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row)).ClearContents
        .Range("A4").Resize(UBound(newArr, 1), UBound(newArr, 2)).Value = newArr

        If Not IsEmpty(.Range("AA4")) Then
            targetRow = .Range("AA4").End(xlDown).Row + 1
            If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 28)).Delete
        End If

        .Range("AB4").FormulaArray = "=Z4&Y4"
        .Range("AB4").AutoFill Destination:=.Range("AB4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row))
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("A4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row)).ClearContents
            .Range("A4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

            If Not IsEmpty(.Range("AA4")) Then
                targetRow = .Range("AA4").End(xlDown).Row + 1
                If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 28)).Delete
            End If

            .Range("AB4").FormulaArray = "=Z4&Y4"
            .Range("AB4").AutoFill Destination:=.Range("AB4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row))
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
End Sub

[/vba]

Логика таже, становитесь на ячейку в диапазоне A4:AB и запускаете макрос. Удачи.

Egider, Может кто сможет оптимальнее но как умею:

[vba]

Код

Option Explicit

Sub Вариант3()
    Dim i As Long, targetRow As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "AB").End(xlUp).Row

        If ActiveCell.Row < 4 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("A4:AB" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 3

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 27)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To UBound(arr, 2))

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                Dim j As Long

                For j = 1 To UBound(arr, 2)
                    newArr(outIndex, j) = arr(i, j)
                Next j

                If IsNumeric(arr(i, 27)) Then

                    If arr(i, 27) > удалённоеЧисло Then
                        newArr(outIndex, 27) = arr(i, 27) - 1
                    Else
                        newArr(outIndex, 27) = arr(i, 27)
                    End If

                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Range("A4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row)).ClearContents
        .Range("A4").Resize(UBound(newArr, 1), UBound(newArr, 2)).Value = newArr

        If Not IsEmpty(.Range("AA4")) Then
            targetRow = .Range("AA4").End(xlDown).Row + 1
            If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 28)).Delete
        End If

        .Range("AB4").FormulaArray = "=Z4&Y4"
        .Range("AB4").AutoFill Destination:=.Range("AB4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row))
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("A4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row)).ClearContents
            .Range("A4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

            If Not IsEmpty(.Range("AA4")) Then
                targetRow = .Range("AA4").End(xlDown).Row + 1
                If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 28)).Delete
            End If

            .Range("AB4").FormulaArray = "=Z4&Y4"
            .Range("AB4").AutoFill Destination:=.Range("AB4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row))
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
End Sub

[/vba]

Логика таже, становитесь на ячейку в диапазоне A4:AB и запускаете макрос. Удачи.MikeVol

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

Сообщение отредактировал MikeVol - Четверг, 17.07.2025, 00:00

Ответить

СообщениеEgider, Может кто сможет оптимальнее но как умею:

[vba]

Код

Option Explicit

Sub Вариант3()
    Dim i As Long, targetRow As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "AB").End(xlUp).Row

        If ActiveCell.Row < 4 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("A4:AB" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 3

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 27)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To UBound(arr, 2))

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                Dim j As Long

                For j = 1 To UBound(arr, 2)
                    newArr(outIndex, j) = arr(i, j)
                Next j

                If IsNumeric(arr(i, 27)) Then

                    If arr(i, 27) > удалённоеЧисло Then
                        newArr(outIndex, 27) = arr(i, 27) - 1
                    Else
                        newArr(outIndex, 27) = arr(i, 27)
                    End If

                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Range("A4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row)).ClearContents
        .Range("A4").Resize(UBound(newArr, 1), UBound(newArr, 2)).Value = newArr

        If Not IsEmpty(.Range("AA4")) Then
            targetRow = .Range("AA4").End(xlDown).Row + 1
            If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 28)).Delete
        End If

        .Range("AB4").FormulaArray = "=Z4&Y4"
        .Range("AB4").AutoFill Destination:=.Range("AB4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row))
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("A4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row)).ClearContents
            .Range("A4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

            If Not IsEmpty(.Range("AA4")) Then
                targetRow = .Range("AA4").End(xlDown).Row + 1
                If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 28)).Delete
            End If

            .Range("AB4").FormulaArray = "=Z4&Y4"
            .Range("AB4").AutoFill Destination:=.Range("AB4:AB" & Application.Max(4, .Cells(.Rows.Count, "AA").End(xlUp).Row))
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
End Sub

[/vba]

Логика таже, становитесь на ячейку в диапазоне A4:AB и запускаете макрос. Удачи.

Автор - MikeVol
Дата добавления - 16.07.2025 в 18:11

Дата: Среда, 16.07.2025, 19:35 | Сообщение № 18

Egider

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

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

Сообщений: 73

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

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

Excel 2016

Уважаемый MikeVol, это здорово, спасибо ВАМ!!!

Пенсионер

Ответить

Дата: Воскресенье, 20.07.2025, 00:31 | Сообщение № 19

Egider

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

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

Сообщений: 73

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

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

Excel 2016

Уважаемые форумчане, уважаемый MikeVol, помогите решить эту задачу: почему после нажатия коммандбутон6 на юзерформе и исполнении команды на нумерацию строк в Екселе, не закрывается сама форма?

Пенсионер

Сообщение отредактировал Egider - Воскресенье, 20.07.2025, 00:46

Ответить

Дата: Воскресенье, 20.07.2025, 00:46 | Сообщение № 20

Egider

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

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

Сообщений: 73

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

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

Excel 2016

[vba]

Код

Option Explicit
Private Sub CommandButton6_Click()
    Dim i As Long, targetRow As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "Y").End(xlUp).Row

        If ActiveCell.Row < 4 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("A4:Y" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 3

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 24)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To UBound(arr, 2))
        '        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To 2)

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                Dim j As Long

                For j = 1 To UBound(arr, 2)
                    newArr(outIndex, j) = arr(i, j)
                Next j

                If IsNumeric(arr(i, 24)) And arr(i, 24) > удалённоеЧисло Then
                    newArr(outIndex, 24) = arr(i, 24) - 1
                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Range("A4:Y" & Application.Max(4, .Cells(.Rows.Count, "L").End(xlUp).Row)).ClearContents
        .Range("A4").Resize(UBound(newArr, 1), UBound(newArr, 2)).Value = newArr

        If Not IsEmpty(.Range("X4")) Then
            targetRow = .Range("X4").End(xlDown).Row + 1
            If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 25)).Delete
        End If

        .Range("Y4").FormulaArray = "=W4&L4&U4"
        .Range("Y4").AutoFill Destination:=.Range("Y4:Y" & Application.Max(4, .Cells(.Rows.Count, "X").End(xlUp).Row))
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("A4:Y" & Application.Max(4, .Cells(.Rows.Count, "L").End(xlUp).Row)).ClearContents
            .Range("A4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

            If Not IsEmpty(.Range("X4")) Then
                targetRow = .Range("X4").End(xlDown).Row + 1
                If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 25)).Delete
            End If

            .Range("Y4").FormulaArray = "=W4&L4&U4"
            .Range("Y4").AutoFill Destination:=.Range("Y4:Y" & Application.Max(4, .Cells(.Rows.Count, "X").End(xlUp).Row))
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
    UserForm1.Hide
    Unload Me
End Sub

[/vba]
Почему не закрывается юзерформа? Не могу понять

[vba]

Код

Option Explicit
Private Sub CommandButton6_Click()
    Dim i As Long, targetRow As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "Y").End(xlUp).Row

        If ActiveCell.Row < 4 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("A4:Y" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 3

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 24)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To UBound(arr, 2))
        '        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To 2)

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                Dim j As Long

                For j = 1 To UBound(arr, 2)
                    newArr(outIndex, j) = arr(i, j)
                Next j

                If IsNumeric(arr(i, 24)) And arr(i, 24) > удалённоеЧисло Then
                    newArr(outIndex, 24) = arr(i, 24) - 1
                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Range("A4:Y" & Application.Max(4, .Cells(.Rows.Count, "L").End(xlUp).Row)).ClearContents
        .Range("A4").Resize(UBound(newArr, 1), UBound(newArr, 2)).Value = newArr

        If Not IsEmpty(.Range("X4")) Then
            targetRow = .Range("X4").End(xlDown).Row + 1
            If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 25)).Delete
        End If

        .Range("Y4").FormulaArray = "=W4&L4&U4"
        .Range("Y4").AutoFill Destination:=.Range("Y4:Y" & Application.Max(4, .Cells(.Rows.Count, "X").End(xlUp).Row))
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("A4:Y" & Application.Max(4, .Cells(.Rows.Count, "L").End(xlUp).Row)).ClearContents
            .Range("A4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

            If Not IsEmpty(.Range("X4")) Then
                targetRow = .Range("X4").End(xlDown).Row + 1
                If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 25)).Delete
            End If

            .Range("Y4").FormulaArray = "=W4&L4&U4"
            .Range("Y4").AutoFill Destination:=.Range("Y4:Y" & Application.Max(4, .Cells(.Rows.Count, "X").End(xlUp).Row))
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
    UserForm1.Hide
    Unload Me
End Sub

[/vba]
Почему не закрывается юзерформа? Не могу понятьEgider

Пенсионер

Сообщение отредактировал Egider - Воскресенье, 20.07.2025, 00:48

Ответить

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

Код

Option Explicit
Private Sub CommandButton6_Click()
    Dim i As Long, targetRow As Long
    On Error GoTo ErrorHandler

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With ThisWorkbook.Worksheets("Лист1")

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "Y").End(xlUp).Row

        If ActiveCell.Row < 4 Or ActiveCell.Row > lastRow Then
            MsgBox "Выберите строку в диапазоне данных!", vbExclamation
            GoTo CleanExit
        End If

        Dim arr     As Variant
        arr = .Range("A4:Y" & lastRow).Value

        Dim восстановить As Boolean
        восстановить = True

        Dim удаляемаяСтрока As Long
        удаляемаяСтрока = ActiveCell.Row - 3

        Dim удалённоеЧисло As Long
        удалённоеЧисло = arr(удаляемаяСтрока, 24)

        Dim newArr() As Variant
        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To UBound(arr, 2))
        '        ReDim newArr(1 To UBound(arr, 1) - 1, 1 To 2)

        Dim outIndex As Long
        outIndex = 1

        For i = 1 To UBound(arr, 1)

            If i <> удаляемаяСтрока Then
                Dim j As Long

                For j = 1 To UBound(arr, 2)
                    newArr(outIndex, j) = arr(i, j)
                Next j

                If IsNumeric(arr(i, 24)) And arr(i, 24) > удалённоеЧисло Then
                    newArr(outIndex, 24) = arr(i, 24) - 1
                End If

                outIndex = outIndex + 1
            End If

        Next i

        .Range("A4:Y" & Application.Max(4, .Cells(.Rows.Count, "L").End(xlUp).Row)).ClearContents
        .Range("A4").Resize(UBound(newArr, 1), UBound(newArr, 2)).Value = newArr

        If Not IsEmpty(.Range("X4")) Then
            targetRow = .Range("X4").End(xlDown).Row + 1
            If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 25)).Delete
        End If

        .Range("Y4").FormulaArray = "=W4&L4&U4"
        .Range("Y4").AutoFill Destination:=.Range("Y4:Y" & Application.Max(4, .Cells(.Rows.Count, "X").End(xlUp).Row))
    End With

    восстановить = False

CleanExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    Exit Sub

ErrorHandler:

    If восстановить Then

        With ThisWorkbook.Worksheets("Лист1")
            .Range("A4:Y" & Application.Max(4, .Cells(.Rows.Count, "L").End(xlUp).Row)).ClearContents
            .Range("A4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

            If Not IsEmpty(.Range("X4")) Then
                targetRow = .Range("X4").End(xlDown).Row + 1
                If targetRow <= .Rows.Count Then .Range(.Cells(targetRow, 1), .Cells(targetRow, 25)).Delete
            End If

            .Range("Y4").FormulaArray = "=W4&L4&U4"
            .Range("Y4").AutoFill Destination:=.Range("Y4:Y" & Application.Max(4, .Cells(.Rows.Count, "X").End(xlUp).Row))
        End With

        MsgBox "Произошла ошибка: " & Err.Description & vbCrLf & "Данные были восстановлены.", vbCritical
    Else
        MsgBox "Произошла ошибка: " & Err.Description, vbCritical
    End If

    Resume CleanExit
    UserForm1.Hide
    Unload Me
End Sub

[/vba]
Почему не закрывается юзерформа? Не могу понять

Автор - Egider
Дата добавления - 20.07.2025 в 00:46

Сохранение нумерации строк после сортировки (Формулы/Formulas)

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

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