Сдвиг значения строки в Excel с помощью макроса после удаления строки

Question

Итак, я использую этот макрос для поиска по id (серийному номеру), а затем удаляю элементы строки для этой конкретной строки. Код для удаления строки:

Sub DeleteMe()
'declare the variables
Dim ID As Range, c As Range, orange As Range
Dim wb As Workbook
Set wb = ThisWorkbook
Set Fws = wb.Sheets("Data")
Set Bws = wb.Sheets("Bookings")
Dim lastrow As Long
'set the object variable
Set ID = Bws.Range("B3")
'stop screen flicker
Application.ScreenUpdating = False
lastrow = Fws.Range("A" & Rows.Count).End(xlUp).Row
Set orange = Fws.Range("A2:A" & lastrow)
'find the value in the range
For Each c In orange
    If c.Value = ID.Value Then
'delete the row
        c.Cells(1, 2).Clear
        c.Cells(1, 3).Clear
        c.Cells(1, 4).Clear
        c.Cells(1, 5).Clear
        c.Cells(1, 6).Clear
        c.Cells(1, 7).Clear
        c.Cells(1, 8).Clear
        c.Cells(1, 9).Clear
        c.Cells(1, 10).Clear
        c.Cells(1, 11).Clear
        c.Cells(1, 12).Clear
        c.Cells(1, 13).Clear
        c.Clear

    End If

Next c

Sheet2.Select

End Sub

Я не удаляю всю строку, потому что в других столбцах есть значения, к которым я не хочу прикасаться

После запуска кода моя база данных выглядит следующим образом:

Мне нужно сдвинуть все оставшиеся строки вверх, чтобы заполнить пустую строку. Я также хочу, чтобы серийные номера менялись соответствующим образом. Так что в этом случае 7 станет 6, а 8 станет 7.

Заранее спасибо!

Answer 1

Пожалуйста, попробуйте этот код. Он должен делать то, что вы хотите.

Sub DeleteMe()
    ' 018

    'declare the variables
    Dim Wb As Workbook
    Dim Fws As Worksheet, Bws As Worksheet
    Dim DelRng As Range
    Dim Id As String
    Dim Rl As Long                              ' last row
    Dim R As Long                               ' row counter

    'set the object variables
    Set Wb = ThisWorkbook
    Set Fws = Wb.Sheets("Data")
    Set Bws = Wb.Sheets("Bookings")

    'stop screen flicker
    Application.ScreenUpdating = False

    Set Id = Bws.Range("B3")
    With Fws
        ' loop through all cells from bottom to top
        ' because row numbers will change as you delete cells
        For R = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
            'find the value in each row
            If .Cells(R, "A").Value = Id.Value Then
                Set DelRng = .Range(.Cells(R, 1), .Cells(R, 13))
                DelRng.Delete Shift:=xlUp
            End If
        Next R

        Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
        For R = 2 To Rl
            .Cells(R, "A").Value = R - 1
        Next R
    End With
End Sub

Answer 2

Попробуйте это .. Цикл вверх помогает обеспечить покрытие всех рядов. Потому что если мы удаляем l oop вниз после удаления строки, то следующий номер строки становится i -1

Sub DeleteMe()
'declare the variables
Dim Fws As Worksheet, Bws As Worksheet
Dim ID As Range
Dim wb As Workbook
Set wb = ThisWorkbook
Set Fws = wb.Sheets("Data")
Set Bws = wb.Sheets("Bookings")
Dim lastrow As Long
'set the object variable
Set ID = Bws.Range("B3")
'stop screen flicker
Application.ScreenUpdating = False
lastrow = Fws.Range("A" & Rows.Count).End(xlUp).Row
'find the value in the range
Fws.Select
For i = lastrow To 2 Step -1
    If Fws.Cells(i, 1) = ID.Value Then
'delete the row
        Fws.Range(Cells(i, 1), Cells(i, 13)).Delete Shift:=xlUp
    End If
Next

With Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    .Formula = "=ROW() - 1"
    .Value = .Value
End With

End Sub