How to pass information from txt to excel by vba

user_16716354 0
Viewed 47

I need a favor here i have a code that i need to transcript a txt file to excel without losing information and spliting it by a "-".

the vba is generating an error call 53 where it says that the file cant be found but thats the right direction of it

Sub inportartxt()
Dim i, j As Integer, fn As Integer, cadena As String, ruta As String, arr, arr2

fn = FreeFile

For k = 1 To 30
    arr2 = "C:\Users\pipet\Desktop\Proyecto Sad\Proyecto 2\Demandas\demanda_1_06"

ruta = arr2

Open ruta For Input As #fn

Do While Not EOF(fn)
    
    Line Input #fn, cadena
    i = i + 1
    arr = Split(cadena, "-")
    For j = o To UBound(arr)
        Sheets("Hoja1").Cells(i, j).Value = cadena
        Next j
    Loop
Next k
End Sub
txt vba excel
1 Answers

Import From Text File

Sub ImportFromTextFile()
    
    Const FilePath As String = "C:\Test\Test.txt"
    Const wsName As String = "Sheet1"
    Const FirstCellAddress As String = "A1"
    Const LineDelimiter As String = vbLf ' possibly 'vbCrLf'
    Const ColumnDelimiter As String = "-"
    
    Dim Data As Variant: Data = GetTextFile(FilePath, LineDelimiter)
    If IsEmpty(Data) Then Exit Sub
    
    Dim rCount As Long: rCount = UBound(Data)
    ReDim Preserve Data(1 To rCount, 1 To 2)
    
    Dim r As Long
    Dim cCount As Long
    
    For r = 1 To rCount
        If Len(Data(r, 1)) > 0 Then
            Data(r, 1) = Split(Data(r, 1), ColumnDelimiter)
            Data(r, 2) = UBound(Data(r, 1))
            If Data(r, 2) > cCount Then cCount = Data(r, 2)
        End If
    Next r
    
    cCount = cCount + 1
    ReDim Preserve Data(1 To rCount, 1 To cCount)
    
    Dim c As Long
    Dim Words() As String
    
    For r = 1 To rCount
        If Not IsEmpty(Data(r, 2)) Then
            If Data(r, 2) = 0 Then Data(r, 2) = Empty
            Words = Data(r, 1)
            For c = 0 To Data(r, 2)
                Data(r, c + 1) = Words(c)
            Next c
        End If
    Next r
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(wsName)
    
    With ws.Range(FirstCellAddress).Resize(, cCount)
        ' Write data.
        .Resize(rCount).Value = Data
        ' Clear below.
        .Resize(ws.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
        ' Apply some formatting.
        '.Font.Bold = True ' headers
        '.EntireColumn.AutoFit ' columns
    End With
    
    MsgBox "Text file imported.", vbInformation

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes each line from a text file to a 2D one-based one-column
'               array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetTextFile( _
    ByVal FilePath As String, _
    Optional ByVal LineSeparator As String = vbLf) _
As Variant
    Const ProcName As String = "GetTextFile"
    On Error GoTo ClearError
    
    Dim TextFile As Long: TextFile = FreeFile
    
    Dim TextLines() As String
    
    Open FilePath For Input Access Read As TextFile
        On Error Resume Next
            TextLines = Split(Input(LOF(TextFile), TextFile), LineSeparator)
        On Error GoTo ClearError
    Close TextFile
    
    Dim Data As Variant: ReDim Data(1 To UBound(TextLines) + 1, 1 To 1)
    
    Dim n As Long
    
    For n = 0 To UBound(TextLines)
        Data(n + 1, 1) = TextLines(n)
    Next n
    
    GetTextFile = Data

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function
user_98140690
Related