Question

我试图从excel中的单元格中仅删除空行。以下是我正在努力实现的目标：

+-----------------+    +---------------------+    +---------------------+
|  EXAMPLE DATA   |    |    EXPLANATION      |    |   EXPECTED RESULT   |
+-----------------+    +---------------------+    +---------------------+
| cell1_text1     |    | cell1_text1         |    | cell1_text1         |
| cell1_text2     |    | cell1_text2         |    | cell1_text2         |
+-----------------+    +---------------------+    +---------------------+
|                 |    | cell2_empty_line    |    | cell2_text1         | 
| cell2_text1     |    | cell2_text1         |    +---------------------+ 
+-----------------+    +---------------------+    | cell3_text1         | 
| cell3_text1     |    | cell3_text1         |    | cell3_text2         | 
|                 |    | cell3_emptyline     |    +---------------------+ 
| cell3_text2     |    | cell3_text2         |    | cell4_text1         | 
+-----------------+    +---------------------+    +---------------------+ 
|                 |    | cell4_emptyline     |    | cell5_text1         | 
|                 |    | cell4_emptyline     |    +---------------------+ 
| cell4_text1     |    | cell4_text1         |    | cell6_text1         | 
+-----------------+    +---------------------+    | cell6_text2         | 
| cell5_text1     |    | cell5_text1         |    | cell6_text3         | 
+-----------------+    +---------------------+    | cell6_text4         | 
| cell6_text1     |    | cell6_text1         |    +---------------------+ 
| cell6_text2     |    | cell6_text2         |
| cell6_text3     |    | cell6_text3         |
|                 |    | cell6_emptyline     |
| cell6_text4     |    | cell6_text4         |
+-----------------+    +---------------------+

我有found this script：

Sub RemoveCarriageReturns()
    Dim MyRange As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For Each MyRange In ActiveSheet.UsedRange
        If 0 < InStr(MyRange, Chr(10)) Then
            MyRange = Replace(MyRange, Chr(10), "")
        End If
    Next

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

但它没有给我想要的结果，它会删除所有单元格中的所有分隔线。

+---------------------------------------------+
|          CURRENT SCRIPT RESULT              |
+---------------------------------------------+
| cell1_text1cell1_text2                      |
+---------------------------------------------+
| cell2_text1                                 |
+---------------------------------------------+
| cell3_text1cell3_text2                      |
+---------------------------------------------+
| cell4_text1                                 |
+---------------------------------------------+
| cell5_text1                                 |
+---------------------------------------------+
| cell6_text1cell6_text2cell6_text3cell6_text4|
+---------------------------------------------+

如何测试行是否包含任何其他字母并仅删除单元格中的该行？如何将该宏仅应用于当前选定的单元格？

Answer 1

您需要找到并删除错误的换行符（例如vbLF，Chr(10)或ASCII 010 dec）。如果数据是从外部源复制的，则可能是恶意回车字符（例如vbCR或Chr(13)）可能已经捎带，并且这些字符也应该被擦除。

Sub clean_blank_lines()
    Dim rw As Long

    With Worksheets("Sheet3")   '<~~SET THIS WORKSHEET REFERENCE PROPERLY!
        For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            With .Cells(rw, 1)
                .Value = Replace(.Value2, Chr(13), Chr(10))
                Do While Left(.Value2, 1) = Chr(10): .Value = Mid(.Value2, 2): Loop
                Do While CBool(InStr(1, .Value, Chr(10) & Chr(10)))
                    .Value = Replace(.Value2, Chr(10) & Chr(10), Chr(10))
                Loop
                Do While Right(.Value2, 1) = Chr(10): .Value = Left(.Value2, Len(.Value2) - 1): Loop
            End With
            .Rows(rw).EntireRow.AutoFit
        Next rw
    End With
End Sub

在完成的单元格上执行Range.AutoFit以移除死的“空白区域”。

<子>之前 <子>后

要将此转换为处理一个或多个所选单元格的宏，请参阅Examples of Selection-based sub framework中的How to avoid using Select in Excel VBA macros。

Answer 2

这样做：

不是替换回车符，而是拆分它然后循环遍历并用仅具有值的项替换该值。

Sub RemoveCarriageReturns()
    Dim MyRange As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For Each MyRange In ActiveSheet.UsedRange
        Dim textArr() As String
        textArr = Split(MyRange.Value, Chr(10))
        MyRange.Value = ""
        For i = LBound(textArr) To UBound(textArr)
            If textArr(i) <> "" Then
                If MyRange.Value = "" Then
                    MyRange.Value = textArr(i)
                Else
                    MyRange.Value = MyRange.Value & Chr(10) & textArr(i)
                End If
            End If
        Next i
    Next

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

从选定的单元格中删除空行

2 个答案: