Разбейте позиции в одной ячейке и выделите

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.

Мне нужны были все доктора и Кр. отдельные позиции, разделенные на отдельные ячейки.

Например, в ячейке A2 мне нужно

Dr. 1392.9999 Accounts Receivable Reconciled

И ячейка А3 будет

Cr. 1092.5921 Other Revenues

И ячейка А4 будет

Dr. 9821.0000 Accounts Payable

И ячейка А5 будет

Cr. 4322.9820 Redemptions Payable    

Я пытался использовать текст для столбцов и разрывы строк, но он разбивает все данные в ячейке, но мне просто нужны доктор и Кр. позиции.

Спасибо

Answer 1

Используйте одну из 2 версий ниже

---

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