与VBA中的内容一起拆分单元格

我有一个macros，它用分行的多行数据分割单元，它工作的很顺利。 不过，我已经碰到macros在分离时留下一些空白单元格的凹凸。 我有一定的代码来识别空白单元格，并删除它们，但不知何故，它不工作。 所以我不知道我把testing空白代码放在正确的位置？ 他们似乎是正确的代码，虽然检查空白代码。

这是我的代码：

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 

这里是样本的打印屏幕，通常主机名和IP地址将逐行显示，但如果在两行之间有空行，则会将其分割为空白单元格。 空白单元格将停止整个循环的工作。

编辑：注意到一些空白单元格是在代码运行时创build的。

Answer 1

也许这个单元并不像之前的评论中提出的那样真的是空的。 你确认这些电池真的是空的吗？

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

Answer 2

试试这个代码。 我已经评论它来解释我在做什么，但让我知道，如果你需要进一步细分它的工作原理。 我添加了error handling来处理预期的和意外的情况。

编辑：我已经添加了一个函数清理分割/转置循环中的并发分隔符创build的单元格，并将删除空行的步骤后执行循环做清理这些。

 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