Question

我有一个Excel电子表格，用于我需要在VBA中拆分的工作。有几列有多行文本，有些则没有。我已经弄清楚如何分割多行文本，我的问题是将列与单行文本并将其复制下来。例如：

Company_Name     Drug_1      Phase_2        USA
                 Drug_2      Discontinued 
                 Drug_3      Phase_1        Europe
                 Drug_4      Discontinued

下面是我用来拆分B＆amp;列的代码。 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

在之前和之后，显示代码填写。

enter image description here

工作原理

此代码的工作原理是获取所有空白单元格的范围。默认情况下，SpecialCells仅查看UsedRange，因为quirk with xlCellTypeBlanks。从那里，它使用End(xlUp)将空白单元格的值设置为等于其顶部的最近单元格。错误处理已到位，因为如果找不到任何内容，xlCellTypeBlanks将返回错误。如果你在顶部做了一个空白行（如图片），那么错误永远不会被触发。

计算单元格中的文本行

1 个答案: