Question

我的数据在一个单元格中有多个条目，我需要将各个条目分成多个单元格。

例如：

单元格A1中的

我有这些数据：

Corporate
Dr. 1392.9999 Accounts Receivable Reconciled
 Cr. 1092.5921 Other Revenues

Back Office
Dr. 9821.0000 Accounts Payable
 Cr. 4322.9820 Redemptions Payable

Note: These accounts are related to the payments received and sold.

我需要所有的Dr.和Cr。订单项分为不同的单元格。

例如，在Cell A2中我需要

Dr. 1392.9999 Accounts Receivable Reconciled

细胞A3

Cr. 1092.5921 Other Revenues

细胞A4

Dr. 9821.0000 Accounts Payable

和细胞A5

Cr. 4322.9820 Redemptions Payable

我尝试使用文本到列并使用换行符，但它会打破单元格中的所有数据，但我只需要Dr.和Cr。订单项。

由于

Answer 1

使用以下两个版本之一

Option Explicit

Public Sub ExtractDrCrV1()
    Dim txt As String, arr As Variant, drcr As Variant, itm As Variant, r As Long

    txt = Sheet1.Range("A1").Value2
    arr = Split(txt, Chr(10))
    ReDim drcr(1 To UBound(arr), 1 To 1)
    For Each itm In arr
        If InStr(1, itm, "Dr.") > 0 Or InStr(1, itm, "Cr.") > 0 Then
            r = r + 1
            drcr(r, 1) = Trim$(itm)
        End If
    Next
    Sheet1.Range("A2:A" & r + 1) = drcr
End Sub

Public Sub ExtractDrCrV2()

    Const R1 = "A1"
    Const R2 = "A2"

    Application.ScreenUpdating = False
    With Sheet1
        .Range(R1).TextToColumns Destination:=.Range(R2), DataType:=xlDelimited, _
                                 Other:=True, OtherChar:=Chr(10)
        .UsedRange.Rows(2).Copy
        .Range(R2).Offset(1).PasteSpecial Transpose:=True: .Range(R1).Select
        With .UsedRange.Columns(1)
         .AutoFilter Field:=1, Criteria1:="<>*Dr.*", Operator:=xlAnd, Criteria2:="<>*Cr.*"
          Sheet1.UsedRange.Offset(1).EntireRow.Delete
         .AutoFilter
        End With
        .UsedRange.Offset(1).Columns(1).Replace " Cr.", "Cr."
    End With
    Application.ScreenUpdating = True
End Sub

在一个单元格中分隔行项目并分开

1 个答案: