Doriți să păstrați spațiul (delimitatorii) după convertirea fișierelor text în foi?

Ați putea încărca fișierul text și rezultatul pe care îl doriți pentru mine?

Bună ziua, Des și PB Rama Murty, codul de mai jos poate împărți datele în coloane pe baza spațiului sau a filei în timpul importării fișierului text în foi. Puteți încerca.

Sub ImportTextToExcel()
'Actualizare deExtendoffice20180911
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ca șir
Dim xRg As Range
Dim xArr
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & „*.txt”)
Dacă xFile = "" Atunci
MsgBox „Nu s-au găsit fișiere”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Faceți în timp ce xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Buclă
Setați xToBook = ThisWorkbook
La data de eroare CV următoare
Application.ScreenUpdating = Fals
Dacă xFiles.Count > 0 Atunci

Pentru I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Foaie de lucru(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Închide False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Pentru xFNum = 1 Pentru xIntRow
Set xRg = ActiveSheet.Range(„A” și xFNum)
xArr = Split(xRg.Text, " ")
Dacă UBound(xArr) > 0, atunci
Pentru xFArr = 0 To UBound(xArr)
Dacă xArr(xFArr) <> "" Atunci
xRg.Value = xArr(xFArr)
Set xRg = xRg.Offset(ColumnOffset:=1)
Final, dacă
Pagina Următoare →
Final, dacă
Pagina Următoare →
Pagina Următoare →
Final, dacă
Application.ScreenUpdating = Adevărat
End Sub

Ce modificări trebuie făcute dacă am nevoie de toate datele în coloane bazate pe virgulă?

Am folosit asta și funcționează, dar aș dori ca totul să fie salvat pe o singură foaie, deoarece fiecare foaie este aceeași informație, sunt doar fișiere jurnal din fiecare zi.
deci trebuie să combin
toate articolele din folder într-o singură foaie
Sub ImportCSVsWithReference()
„Actualizare de KutoolsforExcel20151214
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ca șir
Dim xRg As Range
Dim xArr
La eroare GoTo ErrHandler
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
Set xSht = ThisWorkbook.ActiveSheet
Dacă MsgBox(„Ștergeți foaia existentă înainte de a importa?”, vbYesNo, „Kutools for Excel”) = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = Fals
xFile = Dir(xStrPath & "\" & "*.log")
Faceți în timp ce xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range(„A” și Rows.Count).End(xlUp).Offset(1)
xWb.Închide False
xFile = Dir
Buclă
Application.ScreenUpdating = Adevărat
Ieșiți din Sub
ErrHandler:
MsgBox „fără fișiere txt”, , „Kutools pentru Excel”
End Sub

și acesta care ues spații pentru a dd la fiecare coloană

Sub ImportTextToExcel()
'Actualizare deExtendoffice20180911
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ca șir
Dim xRg As Range
Dim xArr
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & „*.txt”)
Dacă xFile = "" Atunci
MsgBox „Nu s-au găsit fișiere”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Faceți în timp ce xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Buclă
Setați xToBook = ThisWorkbook
La data de eroare CV următoare
Application.ScreenUpdating = Fals
Dacă xFiles.Count > 0 Atunci

Pentru I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Foaie de lucru(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Închide False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Pentru xFNum = 1 Pentru xIntRow
Set xRg = ActiveSheet.Range(„A” și xFNum)
xArr = Split(xRg.Text, " ")
Dacă UBound(xArr) > 0, atunci
Pentru xFArr = 0 To UBound(xArr)
Dacă xArr(xFArr) <> "" Atunci
xRg.Value = xArr(xFArr)
Set xRg = xRg.Offset(ColumnOffset:=1)
Final, dacă
Pagina Următoare →
Final, dacă
Pagina Următoare →
Pagina Următoare →
Final, dacă
Application.ScreenUpdating = Adevărat
End Sub

Puteți utiliza funcția Găsiți și înlocuiți pentru a înlocui mai întâi virgula cu spațiu și aplicați una dintre metodele de mai sus pentru a o converti în fișier Excel.

Vrei să spui să combinați toate fișierele text într-o singură foaie?

Bună, Davidder, poți încerca codul vba de mai jos.

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

Acest cod a funcționat pentru mine, dar totuși, trebuie să schimb ceva în el.

*Vreau să se lipească pe aceeași foaie fără a deschide o foaie nouă, apoi o copiez deoarece durează mai mult timp.

*trebuie să inserați o condițională dacă pentru fișierele txt importate să fie lipite pe foaia 1 dacă începe cu litera A și importate în foaia 2 dacă începe cu litera B


Sub testcopy3()
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim i As Long
Dim LastRow As Long
Dim Rng ca rază de acțiune
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & „*.txt”)
Dacă xFile = "" Atunci
MsgBox „Nu s-au găsit fișiere”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Faceți în timp ce xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Buclă
Interval("N2").Selectați
Setați xToBook = ThisWorkbook
Dacă xFiles.Count > 0 Atunci
Pentru i = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Activare
„Selectarea și copierea datelor txt
Interval(Selectie, Selection.End(xlDown)).Select
Selectare.Copiere
xToBook.Activate
ActiveSheet.Paste
Selection.End(xlDown).Offset(1).Select
La data de eroare CV următoare
La eroare GoTo 0
xWb.Închide False
Pagina Următoare →
Final, dacă
End Sub

Îmi pare rău, am mâinile legate

Ne pare rău, Harsh, ai grijă să nu faci importuri repetate.

Pooja, puteți încerca funcția Eliminați zerourile de început din Kutools pentru Excel pentru a elimina toate zerourile de început din selecție după importare.

Dacă doriți să păstrați zerourile inițiale, le puteți formata ca format text în format de celulă.

Bună, vă rugăm să încercați codul de mai jos

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

Bună, Daniel, încearcă codul de mai jos, importă toate fișierele text într-o singură foaie numită Txt.
Observați că: dacă numele textului este același cu numele foii existente, este posibil ca fișierul text să nu fie importat.

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