计算单元格中的文本行数

Question

我有一个工作数据的 Excel 电子表格，需要在 VBA 中拆分。几列有多行文本，而其他列则没有。我已经想出了如何拆分多行文本，我的问题是用单行文本获取列并将其复制下来。例如：

Company_Name     Drug_1      Phase_2        USA
                 Drug_2      Discontinued 
                 Drug_3      Phase_1        Europe
                 Drug_4      Discontinued  

下面是我用来拆分列 B 和 C 的代码，然后我可以手动处理 D，但是我需要将列 A 复制到第 2-4 行。有超过 600 行这样的行，否则我只会手动执行。 （注意：我将 B 列放入下面的 A 中，将 C 列放入 C 中）

Sub Splitter()
    Dim iPtr1 As Integer
    Dim iPtr2 As Integer
    Dim iBreak As Integer
    Dim myVar As Integer
    Dim strTemp As String
    Dim iRow As Integer

'column A loop
    iRow = 0
    For iPtr1 = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        strTemp = Cells(iPtr1, 1)
        iBreak = InStr(strTemp, vbLf)
        Range("C1").Value = iBreak
            Do Until iBreak = 0
            If Len(Trim(Left(strTemp, iBreak - 1))) > 0 Then
                iRow = iRow + 1
                Cells(iRow, 2) = Left(strTemp, iBreak - 1)
            End If
            strTemp = Mid(strTemp, iBreak + 1)
            iBreak = InStr(strTemp, vbLf)
        Loop
        If Len(Trim(strTemp)) > 0 Then
            iRow = iRow + 1
            Cells(iRow, 2) = strTemp
        End If
    Next iPtr1

'column C loop
    iRow = 0
    For iPtr2 = 1 To Cells(Rows.Count, 3).End(xlUp).Row
        strTemp = Cells(iPtr2, 3)
        iBreak = InStr(strTemp, vbLf)
        Do Until iBreak = 0
            If Len(Trim(Left(strTemp, iBreak - 1))) > 0 Then
                iRow = iRow + 1
                Cells(iRow, 4) = Left(strTemp, iBreak - 1)
            End If
            strTemp = Mid(strTemp, iBreak + 1)
            iBreak = InStr(strTemp, vbLf)
        Loop
        If Len(Trim(strTemp)) > 0 Then
            iRow = iRow + 1
            Cells(iRow, 4) = strTemp
        End If
    Next iPtr2

End Sub

Answer 1

有一些我称之为“瀑布填充”的代码正是这样做的。如果您可以构建一系列单元格来填充（即设置rng_in），它会做到这一点。它适用于任意数量的列，这是一个不错的功能。你可以诚实地给它输入A:D 的范围，它会擦掉你的空白。

Sub FillValueDown()

    Dim rng_in As Range
    Set rng_in = Range("B:B")

    On Error Resume Next

        Dim rng_cell As Range
        For Each rng_cell In rng_in.SpecialCells(xlCellTypeBlanks)
            rng_cell = rng_cell.End(xlUp)
        Next rng_cell

    On Error GoTo 0

End Sub

之前和之后，显示代码填充。

工作原理

此代码通过获取所有空白单元格的范围来工作。默认情况下，SpecialCells 只查看UsedRange，因为quirk with xlCellTypeBlanks。从那里它使用End(xlUp) 将空白单元格的值设置为等于其顶部最近的单元格。错误处理已经到位，因为如果没有找到任何内容，xlCellTypeBlanks 将返回错误。但是，如果您在整个列的顶部使用空白行（如图所示），则永远不会触发错误。