Остановить макрос VBA при достижении пустой строки

Question

Недавно я пытался использовать макросы для упрощения некоторых задач в Excel 2010, так как я работаю с огромными банками данных.

Я уже нашел код, необходимый для объединения повторяющихся строк и объединения уникальных данных / комментариев благодаря этому спасающему жизнь потоку: как объединить значения из нескольких строк в одну строку в Excel?

Код был легок для понимания для начинающего, такого как я (я хочу и пытаюсь понять, что я делаю, вместо того, чтобы просто слепо вставлять копии). Единственная проблема, с которой я столкнулся, заключается в том, что макрос, похоже, не останавливается на последнем ряду и в итоге заполняет остальную часть листа Excel.

Желаемый результат был получен, как видно в ряду с 4 по 6, но начиная с ряда 29 ... Однако вы можете видеть, что начиная со строки 29, макрос продолжает добавлять «;» в 10-м столбце.

Вот код, который я адаптировал:

Sub merge_dupes_and_comments()
'define variables

Dim RowNum As Long, LastRow As Long

Application.ScreenUpdating = False

RowNum = 2
LastRow = Cells.SpecialCells(xlCellTypeLastCell).row
Range("A2", Cells(LastRow, 10)).Select

For Each row In Selection
    With Cells
    'if OC number matches
    If Cells(RowNum, 2) = Cells(RowNum + 1, 2) Then
        'and if position and material match
        If Cells(RowNum, 4) = Cells(RowNum + 1, 4) Then
        If Cells(RowNum, 5) = Cells(RowNum + 1, 5) Then
        'move updated comments up next to the old comment and delete empty line
            Cells(RowNum, 10) = Cells(RowNum, 10) & ";" & Cells(RowNum + 1, 10)
            Rows(RowNum + 1).EntireRow.Delete
       End If
        End If
         End If
         End With

RowNum = RowNum + 1
Next row

Application.ScreenUpdating = True

End Sub

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

Я попытался переопределить последний ряд как:

Dim LastRow As Long

With ThisWorkbook.Worksheets("MasterData") 'enter name of the sheet you're working on
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        LastRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).row
    Else
        LastRow = 1
    End If

Но я отметил любые изменения.

Буду благодарен за любую помощь!

Большое спасибо заранее, КуроНави

Answer 1

Ваша последняя строка не является последней строкой таблицы, но внизу есть 3 пустых строки, которые заполнены; потому что ваш макрос содержит эту строку:

        Cells(RowNum, 10) = Cells(RowNum, 10) & ";" & Cells(RowNum + 1, 10)

Эта команда в основном говорит: объединить пустую строку с пустой строкой и отделить с помощью;

Но вы не хотите проверять наличие пустых строк. Итак, ваш саб должен быть следующим:

Sub merge_dupes_and_comments()
    'define variables
    Dim RowNum As Integer, LastRow As Integer, EmptyCells as Integer

    Application.ScreenUpdating = False

    RowNum = 2
    LastRow = Cells.SpecialCells(xlCellTypeLastCell).row
    Range("A2", Cells(LastRow, 10)).Select

    For Each row In Selection
        'Do we have am empty row? If so exit the loop.
        'Lets count the amount of empty cells on the row.
        EmptyCells=0
        For c = 1 to 10   
            if Cells(RowNum,c) = "" then EmptyCells = EmptyCells+1
        Next c

        'If we find more than 9 empty cells, assume the row is empty, and exit the loop.
        if EmptyCells > 9 then exit for

        'Lets continue the duplicate checking
        'if OC number matches
        'and if position and material match
        If Cells(RowNum, 2) = Cells(RowNum + 1, 2) AND _
           Cells(RowNum, 4) = Cells(RowNum + 1, 4) AND _
           Cells(RowNum, 5) = Cells(RowNum + 1, 5) Then
           'move updated comments up next to the old comment and delete empty line
            Cells(RowNum, 10) = Cells(RowNum, 10) & ";" & Cells(RowNum + 1, 10)
            Rows(RowNum + 1).EntireRow.Delete
       End If

    RowNum = RowNum + 1
Next row

Application.ScreenUpdating = True

End Sub

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