Ali želite obdržati presledek (ločila) po pretvorbi besedilnih datotek v liste?

Ali lahko naložite besedilno datoteko in rezultat, ki ga želite zame?

Pozdravljeni, Des in PB Rama Murty, spodnja koda lahko razdeli podatke v stolpce na podlagi presledka ali tabulatorja, medtem ko uvaža besedilno datoteko na liste. Lahko poskusite.

Sub ImportTextToExcel()
'PosodobitevExtendoffice20180911
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue kot niz
Dim xRg As Range
Dim xArr
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Če je xFile = "" Potem
MsgBox "Ni najdenih datotek", vbInformation, "Kutools za Excel"
Exit Sub
Konec Če
Naredi, medtem ko xFile <> ""
xFiles.Dodaj xFile, xFile
xFile = Dir()
Zanka
Nastavite xToBook = Ta delovni zvezek
On Error Resume Next
Application.ScreenUpdating = Napačno
Če je xFiles.Count > 0 Potem

Za I = 1 Do xFiles.Count
Nastavi xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiraj po:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Zapri False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Za xFNum = 1 do xIntRow
Nastavite xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Če je UBound(xArr) > 0 Potem
Za xFArr = 0 do UBound(xArr)
Če xArr(xFArr) <> "" Potem
xRg.Vrednost = xArr(xFArr)
Nastavi xRg = xRg.Offset(ColumnOffset:=1)
Konec Če
Naslednji
Konec Če
Naslednji
Naslednji
Konec Če
Application.ScreenUpdating = Res
End Sub

Kakšne spremembe je treba narediti, če potrebujem vse podatke v stolpce na podlagi vejice?

Uporabil sem to in deluje, vendar bi rad, da se vse shrani na en list, saj je na vsakem listu enaka informacija, to so le dnevniške datoteke za vsak dan.
zato moram združiti
vse elemente v mapi na en list
Sub ImportCSVsWithReference()
'Posodobi z Kutools forExcel20151214
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue kot niz
Dim xRg As Range
Dim xArr
Ob napaki Pojdi na ErrHandler
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
Nastavite xSht = ThisWorkbook.ActiveSheet
If MsgBox("Počisti obstoječi list pred uvozom?", vbYesNo, "Kutools for Excel") = vbYes Potem xSht.UsedRange.Clear
Application.ScreenUpdating = Napačno
xFile = Dir(xStrPath & "\" & "*.log")
Naredi, medtem ko xFile <> ""
Nastavi xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Zapri False
xDatoteka = Dir
Zanka
Application.ScreenUpdating = Res
Exit Sub
ErrHandler:
MsgBox "brez datotek txt", , "Kutools za Excel"
End Sub

in ta, ki uporablja presledke za dd v vsakem stolpcu

Sub ImportTextToExcel()
'PosodobitevExtendoffice20180911
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue kot niz
Dim xRg As Range
Dim xArr
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Če je xFile = "" Potem
MsgBox "Ni najdenih datotek", vbInformation, "Kutools za Excel"
Exit Sub
Konec Če
Naredi, medtem ko xFile <> ""
xFiles.Dodaj xFile, xFile
xFile = Dir()
Zanka
Nastavite xToBook = Ta delovni zvezek
On Error Resume Next
Application.ScreenUpdating = Napačno
Če je xFiles.Count > 0 Potem

Za I = 1 Do xFiles.Count
Nastavi xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiraj po:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Zapri False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Za xFNum = 1 do xIntRow
Nastavite xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Če je UBound(xArr) > 0 Potem
Za xFArr = 0 do UBound(xArr)
Če xArr(xFArr) <> "" Potem
xRg.Vrednost = xArr(xFArr)
Nastavi xRg = xRg.Offset(ColumnOffset:=1)
Konec Če
Naslednji
Konec Če
Naslednji
Naslednji
Konec Če
Application.ScreenUpdating = Res
End Sub

Uporabite lahko funkcijo Find and Replace, da najprej zamenjate vejico s presledkom, in uporabite eno od zgornjih metod, da jo pretvorite v datoteko Excel.

Ali mislite združiti vso besedilno datoteko na en list?

Živjo, Davider, poskusiš lahko pod kodo vba.

Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
    Dim xSht  As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet
    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
    Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.txt")
    Do While xFile <> ""
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
        xWb.Close False
        xFile = Dir
    Loop
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "no txt files", , "Kutools for Excel"
End Sub

Ta koda mi je delovala, a vseeno moram nekaj v njej spremeniti.

*Želim, da ga prilepite na isti list brez odpiranja novega lista, nato pa ga kopirate, ker traja dlje časa.

*treba vstaviti pogoj, če za uvožene datoteke txt, ki jih želite prilepiti na list 1, če se začne s črko A, in uvoziti na list 2, če se začne s črko B


Subtestcopy3()
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim i as Long
Zatemni zadnjo vrstico tako dolgo
Dim Rng kot domet
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Če je xFile = "" Potem
MsgBox "Ni najdenih datotek", vbInformation, "Kutools za Excel"
Exit Sub
Konec Če
Naredi, medtem ko xFile <> ""
xFiles.Dodaj xFile, xFile
xFile = Dir()
Zanka
Obseg("N2").Izberi
Nastavite xToBook = Ta delovni zvezek
Če je xFiles.Count > 0 Potem
Za i = 1 Do xFiles.Count
Nastavi xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Aktiviraj
'Izbira in kopiranje podatkov txt
Obseg(Izbor, Izbor.Konec(xlDown)).Izberi
Izbor. Kopija
xToBook.Aktiviraj
ActiveSheet.Prilepi
Izbira.Konec(xlDown).Odmik(1).Izberi
On Error Resume Next
Ob napaki Pojdi na 0
xWb.Zapri False
Naslednji
Konec Če
End Sub

Oprosti, moje roke so vezane

Oprosti, Harsh, samo pazi, da se izogneš ponovnemu uvažanju.

Pooja, lahko poskusiš funkcijo Odstrani vodilne ničle Kutools za Excel, da po uvozu odstraniš vse vodilne ničle iz izbire.

Če želite obdržati vodilne ničle, jih lahko oblikujete kot obliko besedila z obliko celic.

Pozdravljeni, poskusite spodnjo kodo

Sub Test()
    'UpdatebyExtendoffice 10/26/2022
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Dim J As Long
    Dim xRg As Range
    Dim xSaveRg As Range
    Dim xSh As Worksheet
    
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    Set xSh = xToBook.Sheets.Add
    Set xRg = xSh.Range("A1")
    J = 1
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            Set xSaveRg = xWb.Worksheets(1).UsedRange
            J = xSaveRg.Rows.Count + 1 + J
            Debug.Print xRg.Address
            xSaveRg.Copy Destination:=xRg
            On Error Resume Next
            xWb.Close False
            
            Set xRg = xSh.Cells(J, 1)
        Next
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Živjo, Daniel, poskusi s spodnjo kodo, uvozi vse besedilne datoteke na en list z imenom Txt.
Upoštevajte naslednje: če je ime besedila enako imenu obstoječega lista, besedilna datoteka morda ne bo uvožena.

Sub ImportTextToExcel2()

'UpdatebyExtendoffice20230106

Dim xWb As Workbook

Dim xToBook As Workbook

Dim xStrPath As String

Dim xFileDialog As FileDialog

Dim xFile As String

Dim xFiles As New Collection

Dim I As Long

Dim xIntRow As Long

Dim xFNum, xFArr As Long

Dim xStrValue As String

Dim xRg As Range

Dim xArr

Dim xRowL, xRowH As Integer

Dim xTxtWS, xWSD As Worksheet

Dim xTxtWS_Rg As Range

Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

xFileDialog.AllowMultiSelect = False

xFileDialog.Title = "Select a folder [Kutools for Excel]"

If xFileDialog.Show = -1 Then

xStrPath = xFileDialog.SelectedItems(1)

End If

If xStrPath = "" Then Exit Sub

If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"

xFile = Dir(xStrPath & "*.txt")

If xFile = "" Then

MsgBox "No files found", vbInformation, "Kutools for Excel"

Exit Sub

End If

Do While xFile <> ""

xFiles.Add xFile, xFile

xFile = Dir()

Loop

Set xToBook = ThisWorkbook

On Error Resume Next

Set xTxtWS = xToBook.Worksheets("Txt")

If IsNull(xTxtWS) Or IsEmpty(xTxtWS) Then

    Set xTxtWS = xToBook.Worksheets.Add

    xTxtWS.Name = "Txt"

End If

Application.ScreenUpdating = False

Application.DisplayAlerts = False

xTxtWS.Activate

If xFiles.Count > 0 Then

xRowL = 1

For I = 1 To xFiles.Count

Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))

xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

Set xWSD = xToBook.Sheets(xToBook.Sheets.Count)

xTxtWS.Activate

xWb.Close False

xIntRow = xWSD.UsedRange.CurrentRegion.Rows.Count

    For xFNum = 1 To xIntRow

        Set xRg = xWSD.Range("A" & xFNum)

        xArr = Split(xRg.Text, " ")

        Set xTxtWS_Rg = xTxtWS.Cells.Range("A" & xRowL)

'        If UBound(xArr) > 0 Then

            For xFArr = 0 To UBound(xArr)

                If xArr(xFArr) <> "" Then

                xTxtWS_Rg.Value = xArr(xFArr)

                Set xTxtWS_Rg = xTxtWS_Rg.Offset(ColumnOffset:=1)

                End If

            Next

'        End If

xRowL = xRowL + 1

    Next

xWSD.Delete

Next

End If

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub