Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Присвоение уникального номера ячейке в добавляемой строке макросом
 
#1
22.08.2019 11:39:53
Добрый день. Приведенный ниже макрос добавляет пустые строки в таблицу в загруженном файле по нажатию кнопки.
К сожалению, рабочий файл не удалось, даже, архивированием ужать до 100 кб.
Поэтому, файл приложил отдельно, код для кнопки вставил в сообщение отдельно.
Закавыка в том, что необходимо присваивать вновь добавленным строкам не порядковый номер в столбце "B", а первый свободный пустой номер, а если таких нет, первый номер после максимального имеющегося. Строки могут добавляться в любом месте таблицы. То, есть, встав, например, между номерами 5 и 6 строке должен быть присвоен номер 13. А если, перед этим удалят строки с номерами 7 и 9, то следующей добавленной строке должен быть присвоен номер 7, добавленной за ней - номер 9 а добавленной за ними, уже, номер 13.
Можно ли добавить реализацию такого условия в макрос добавления строки по шелчку кнопки, приведенному ниже?

С уважением,
Олег
Код
Sub Кнопка4_Щелчок()
    Application.ScreenUpdating = False
    If Application.Intersect(ActiveCell, ActiveSheet.UsedRange) Is Nothing _
        Or ActiveCell.Row < 9 Then
            MsgBox "Активная строка вне таблицы"
    Else
        Rows(ActiveCell.Row).Insert
        Rows(ActiveCell.Row + 1).Copy Rows(ActiveCell.Row)
    End If
       Cells(ActiveCell.Row + 1, 3).Resize(, 7).Value = Empty
       Cells(ActiveCell.Row + 1, 11).Resize(, 3).Value = Empty
       Cells(ActiveCell.Row + 1, 15).Resize(, 8).Value = Empty
       Range(Cells(ActiveCell.Row + 1, 4), Cells(ActiveCell.Row + 1, 9)).Locked = False
       Cells(ActiveCell.Row + 1, 22).Locked = False
    Application.ScreenUpdating = True
End Sub
 
 
 
#2
22.08.2019 13:52:46
grand68, Добрый день. Попробуйте так.
Код
Sub Кнопка4_Щелчок()
    Application.ScreenUpdating = False
    Dim i&, k&, a&
    On Error Resume Next
    For i = 1 To 1000
        k = Application.Match(i, [b8:b1000], 0)
        If Err Then Err.Clear: a = i: Exit For
    Next
    If Application.Intersect(ActiveCell, ActiveSheet.UsedRange) Is Nothing _
        Or ActiveCell.Row < 9 Then
            MsgBox "Активная строка вне таблицы"
    Else
        Rows(ActiveCell.Row).Insert
        Rows(ActiveCell.Row + 1).Copy Rows(ActiveCell.Row)
        Cells(ActiveCell.Row, 2) = a
    End If
       Cells(ActiveCell.Row + 1, 3).Resize(, 7).Value = Empty
       Cells(ActiveCell.Row + 1, 11).Resize(, 3).Value = Empty
       Cells(ActiveCell.Row + 1, 15).Resize(, 8.).Value = Empty
       Range(Cells(ActiveCell.Row + 1, 4), Cells(ActiveCell.Row + 1, 9)).Locked = False
       Cells(ActiveCell.Row + 1, 22).Locked = False
    Application.ScreenUpdating = True
End Sub
Изменено: casag - 22.08.2019 13:53:12
 
 
 
#3
22.08.2019 14:21:16
Спасибо огромное, работает.

Единственное, чтобы номер присваивался добавленной строке, нужно вместо
Код
Cells(ActiveCell.Row, 2) = a   поставить   Cells(ActiveCell.Row + 1, 2) = a

Иначе присваивается номер строке выше
Код
Else
        Rows(ActiveCell.Row).Insert
        Rows(ActiveCell.Row + 1).Copy Rows(ActiveCell.Row)
        Cells(ActiveCell.Row + 1, 2) = a
 End If

Привожу корректный вариант этой части кода.
 
 
 
#4
22.08.2019 14:46:19
Цитата
grand68 написал:
Иначе присваивается номер строке выше
Ну, строго говоря, в вашем коде, добавляется именно строка выше активной ячейки и в добавленную строку макрос переносит значения из строки с активной ячейкой.
Так короче будет
Код
Sub Кнопка4_ЩелчокMM()
    Application.ScreenUpdating = False
    Dim i&, k&, a&
    On Error Resume Next
    For i = 1 To 1000
        k = Application.Match(i, [b8:b1000], 0)
        If Err Then Err.Clear: a = i: Exit For
    Next
    If Application.Intersect(ActiveCell, ActiveSheet.UsedRange) Is Nothing _
        Or ActiveCell.Row < 9 Then
            MsgBox "Активная строка вне таблицы"
    Else
        Rows(ActiveCell.Row + 1).Insert
        Cells(ActiveCell.Row + 1, 2) = a
     End If
    Application.ScreenUpdating = True
End Sub
 
 
 
Страницы: 1
Наверх