Чтение LBR (xml) как TXT в Excel vba

Question

Я пытаюсь прочитать файл расширения .LBR (XML язык) в Excel с этим кодом:

Dim X As Double
Dim TXT As String
Open "C:\Users\Asus\Desktop\Test\OJE-SS-124HM_000.lbr" For Input As #1
X = 1
Do While Not EOF(1)
Line Input #1, TXT
Worksheets("LBR").Cells(X, 1) = TXT
X = X + 1
Loop
Close #1

Но я получаю весь текст только в первой ячейке A1, см. нижнее изображение. Я хотел бы получить каждую строку текста в отдельных ячейках, A1, A2, и т. Д. c. Что я делаю не так?

Я думаю, что у файла LBR нет строки разрыва chr(13).

Это мой предпочтительный результат:

Это мой фактический результат:

Answer 1

О, теперь я вижу. Хорошо, основываясь на этом изображении, попробуйте это.

До:

После:

Опция # 1

Const ANALYSIS_ROW As String = "C"
Const DATA_START_ROW As Long = 1

Sub ReplicateData()
    Dim iRow As Long
    Dim lastrow As Long
    Dim ws As Worksheet
    Dim iSplit() As String
    Dim iIndex As Long
    Dim iSize As Long

    'Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With ThisWorkbook
        .Worksheets("Sheet2").Copy After:=.Worksheets("Sheet2")
        Set ws = ActiveSheet
    End With

    With ws
        lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
    End With


    For iRow = lastrow To DATA_START_ROW Step -1
        iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ">")
        iSize = UBound(iSplit) - LBound(iSplit) + 1
        If iSize = 1 Then GoTo Continue

        ws.Rows(iRow).Copy
        ws.Rows(iRow).Resize(iSize - 1).Insert
        For iIndex = LBound(iSplit) To UBound(iSplit)
            ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
        Next iIndex
Continue:
    Next iRow

    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    'Application.ScreenUpdating = True
End Sub

Опция # 2 Sub TryThis ()

Dim lastrow As Integer
Dim i As Integer
Dim descriptions() As String

With ThisWorkbook
    .Worksheets("Sheet2").Copy After:=.Worksheets("Sheet2")
    Set ws = ActiveSheet
End With

With ActiveSheet
    lastrow = .Range("C1").End(xlDown).Row
    For i = lastrow To 2 Step -1
        If InStr(1, .Range("C" & i).Value, ">") <> 0 Then
            descriptions = Split(.Range("C" & i).Value, ">")
        End If
        For Each Item In descriptions
            .Range("C" & i).Value = Item
            .Rows(i).Copy
            .Rows(i).Insert
        Next Item
        .Rows(i).EntireRow.Delete

    Next i
End With

End Sub

Я уверен, что этот код можно настроить немного, но по крайней мере это должно дать вам хорошую отправную точку.

Answer 2

Я думаю, это то, что вы хотите.

Sub SplitCellsBaseLineBreak()
    Dim str() As String
    Dim myRng As Range
    Set myRng = Application.Selection
    Set myRng = Application.InputBox("select one range that you want to split", "SplitCellsBaseLineBreak", myRng.Address, Type:=8)

    For Each myCell In myRng
        If Len(myCell) Then
            str = VBA.Split(myCell, vbLf)
            myCell.Resize(1, UBound(str) + 1).Offset(0, 1) = str
        End If
    Next
End Sub