split cells at line breaks with content with in VBA

Question

I have a macro which splits cells with multiple lines of data at line breaks, it works smoothly. However I've hit a bump that the macro leaves some blank cells while splitting. I have certain code to identify the blank cells and delete them, but somehow it doesn't work. So I wonder do I put the testing blank code at the right position? They seem to be correct code for checking blank code though.

Here's my code:

Sub SplitMultipleHostnames()
Dim tmpArr As Variant


For Each cell In Range("D2", Range("D3").End(xlDown))
If cell <> "" Then
    If InStr(1, cell, Chr(10)) <> 0 Then
        tmpArr = Split(cell, Chr(10))

        cell.EntireRow.Copy

        cell.Offset(1, 0).Resize(UBound(tmpArr), 1).EntireRow.Insert xlShiftDown



        cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)


    End If
Else
    cell.EntireRow.Delete
End If
Next
Application.CutCopyMode = False


End Sub

Here's a print screen of the sample, usually hostnames and ip addresses will be line by line, but if in between there's a empty line, it will be split as a blank cell. And the blank cell will stop the whole loop working.

Edit: Noted that some blank cells are created while the code running.

Answer 1

Maybe the cells aren't really empty as proposed in an earlier comment. Did you verify that these cells are really empty?

If Replace(Replace(Trim(cell.value2), chr(10), ""), vbNewLine, "") <> vbNullString Then

Answer 2

Try this code. I've commented it to explain what I'm doing, but let me know if you need a further breakdown of how it works. I've added error handling to deal with expected and unexpected conditions.

EDIT: I've added a function for cleaning cells created from concurrent delimiters in the split/transpose loop, and moved the delete empty rows step to after the do loop do clean these up.

Sub SplitMultipleHostnames()
    'I've added some error handling. 
    On Error GoTo UnexpectedErr

    'Get the last used cell.
    With Range("D:D")
        Dim LastDataCell As Range
        Set LastDataCell = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
    End With

    'We need to have some data to work upon beyond the first row
    If LastDataCell Is Nothing Then Exit Sub
    If LastDataCell.Row < 2 Then Exit Sub

    'I set a range variable here to make it easier to work with later
    Dim WorkingRange As Range
    Set WorkingRange = Range("D2", LastDataCell)

    'You can avoid expensive loop overhead by just finding the cells containing _
    the character you wish to split upon, and acting upon only these cells
    Dim FoundCell As Range
    Dim FirstAddress As String
    Set FoundCell = WorkingRange.Find(Chr(10), LastDataCell, xlValues, xlPart, xlByRows, xlNext, False, False, False)

    'Another benefit of this approach: if there are no line breaks we can exit early
    If FoundCell Is Nothing Then Exit Sub

    'We are going to use .FindNext to loop through all the cells containing our _
    delmiiter character.  Store first found cell's address so we know when we're done
    FirstAddress = FoundCell.Address

    'Since we know our data type we should declare are variable as such
    Dim tmpArr() As String
    Do
        tmpArr = Split(FoundCell, Chr(10))
        'Use a With block if you're lazy like me ;)
        With FoundCell
            .Offset(1, 0).Resize(UBound(tmpArr), 1).EntireRow.Insert xlShiftDown
            Set FoundCell = FoundCell.Resize(UBound(tmpArr) + 1, 1)
            FoundCell = Application.Transpose(tmpArr)
        End With

        'A cell could contain mulitple concurrent delimiters.
        'We can handle this by finding all concurrent delimiters and replacing with a _
        single delimiter before splitting the cell contents.
        ' - OR -
        'We can split the cell contents and then remove any remaining delimiters afterward

        'I've elected to do the latter as I think it's the simplest route in this application
        Dim CheckCell As Range
        For Each CheckCell In FoundCell
            RemoveDelimiters CheckCell, Chr(10), True
        Next

        'Find the next cell to work upon
        Set FoundCell = WorkingRange.FindNext
        'If we don't find another match, we are done
        If FoundCell Is Nothing Then Exit Do
    Loop While FoundCell.Address <> FirstAddress

    'Now that we are done, we will delete any rows with blank cells
    Dim BlankCells As Range

    'It is possible there are not any empty cells - we should anticipate this error and provide a way to handle it:
    On Error GoTo CatchErr001
    Set BlankCells = WorkingRange.SpecialCells(xlCellTypeBlanks)
    On Error GoTo UnexpectedErr

    'We check condition to see if BlankCells is allocated, as we know it won't be if no blank cells were found
    If Not BlankCells Is Nothing Then BlankCells.EntireRow.Delete

Exit Sub

CatchErr001:
    '1004 is a generic runtime error. It could be because no blank cells found, or something else.
    'If it's due to no blank cells our code is built to deal with this condition so we can safely swallow the error
    If (err.Number = 1004) And (InStr(1, err.Description, "No cells were found", vbTextCompare) > 0) Then
        Resume Next
    'If it's due to something else, our program is in an unknonw state.  This is unexpected
    Else
        GoTo UnexpectedErr
    End If

UnexpectedErr:
    Dim CaughtErr As ErrObject
    Set CaughtErr = err
    On Error GoTo 0
    err.Raise CaughtErr.Number, CaughtErr.Source, CaughtErr.Description, CaughtErr.HelpFile, CaughtErr.HelpContext
End Sub

Private Sub RemoveDelimiters(ByRef CheckCell As Range, ByRef Delimiter As String, Optional ByVal RemoveSpaces As Boolean = False)
    Dim CheckValue As String
    CheckValue = CheckCell.value
    'If the cell is already empty we don't do anything further
    If Len(CheckCell) <= 0 Then Exit Sub
    'Remove spaces if the calling procedure specified to do so
    If RemoveSpaces Then CheckValue = Trim(CheckValue)
    'Remove all delimiter characters
    CheckValue = Replace(CheckCell, Delimiter, "")
    'Replace the cell's value with our modified value
    CheckCell.value = CheckValue
End Sub