Möchten Sie die Leerzeichen (Trennzeichen) beibehalten, nachdem Sie die Textdateien in Blätter konvertiert haben?

Könnten Sie die Textdatei und das gewünschte Ergebnis für mich hochladen?

Hallo, Des und PB Rama Murty, der folgende Code kann Daten basierend auf Leerzeichen oder Tabulatoren in Spalten aufteilen, während Textdateien in Blätter importiert werden. Sie können es versuchen.

Unter ImportTextToExcel()
'UpdatebyExtendoffice20180911
Dim xWb als Arbeitsmappe
Dim xToBook als Arbeitsmappe
Dim xStrPath als Zeichenfolge
Dim xFileDialog As FileDialog
Dim xFile als Zeichenfolge
Dim xFiles als neue Sammlung
Dimme ich so lange
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue als Zeichenfolge
Dim xRg als Bereich
Dim xArr
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Ordner auswählen [Kutools for Excel]"
Wenn xFileDialog.Show = -1 Dann
xStrPath = xFileDialog.SelectedItems(1)
End If
Wenn xStrPath = "" dann Sub beenden
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Wenn xFile = "" Dann
MsgBox "Keine Dateien gefunden", vbInformation, "Kutools für Excel"
Exit Sub
End If
Do While xFile <> ""
xFiles.Add xFile, xFile
xDatei = Dir()
Loop
Legen Sie xToBook = DieseArbeitsmappe fest
On Error Resume Next
Application.ScreenUpdating = False
Wenn xFiles.Count > 0 dann

Für I = 1 bis xFiles.Count
Setze xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopieren nach:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close Falsch
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Für xFNum = 1 bis xIntRow
Setze xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Wenn UBound(xArr) > 0 dann
Für xFArr = 0 bis UBound(xArr)
Wenn xArr(xFArr) <> "" Dann
xRg.Wert = xArr(xFArr)
Setze xRg = xRg.Offset(ColumnOffset:=1)
End If
Weiter
End If
Weiter
Weiter
End If
Application.ScreenUpdating = True
End Sub

Welche Änderungen müssen vorgenommen werden, wenn ich Daten in Spalten basierend auf Kommas zusammenfassen muss?

Ich habe dies verwendet und es funktioniert, aber ich möchte, dass alles auf einem Blatt gespeichert wird, da jedes Blatt dieselben Informationen enthält, von denen sie nur Protokolldateien für jeden Tag sind.
Also muss ich die kombinieren
alle Elemente im Ordner auf einem Blatt
Sub-ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
Dim xWb als Arbeitsmappe
Dim xToBook als Arbeitsmappe
Dim xStrPath als Zeichenfolge
Dim xFileDialog As FileDialog
Dim xFile als Zeichenfolge
Dim xFiles als neue Sammlung
Dimme ich so lange
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue als Zeichenfolge
Dim xRg als Bereich
Dim xArr
Bei Fehler GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Ordner auswählen [Kutools for Excel]"
Wenn xFileDialog.Show = -1 Dann
xStrPath = xFileDialog.SelectedItems(1)
End If
Wenn xStrPath = "" dann Sub beenden
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
Legen Sie xSht = ThisWorkbook.ActiveSheet fest
If MsgBox("Löschen Sie das vorhandene Blatt vor dem Importieren?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
Do While xFile <> ""
Setze xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close Falsch
xDatei = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "keine txt-Dateien", "Kutools für Excel"
End Sub

und dieser, der Leerzeichen verwendet, um jeder Spalte hinzuzufügen

Unter ImportTextToExcel()
'UpdatebyExtendoffice20180911
Dim xWb als Arbeitsmappe
Dim xToBook als Arbeitsmappe
Dim xStrPath als Zeichenfolge
Dim xFileDialog As FileDialog
Dim xFile als Zeichenfolge
Dim xFiles als neue Sammlung
Dimme ich so lange
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue als Zeichenfolge
Dim xRg als Bereich
Dim xArr
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Ordner auswählen [Kutools for Excel]"
Wenn xFileDialog.Show = -1 Dann
xStrPath = xFileDialog.SelectedItems(1)
End If
Wenn xStrPath = "" dann Sub beenden
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Wenn xFile = "" Dann
MsgBox "Keine Dateien gefunden", vbInformation, "Kutools für Excel"
Exit Sub
End If
Do While xFile <> ""
xFiles.Add xFile, xFile
xDatei = Dir()
Loop
Legen Sie xToBook = DieseArbeitsmappe fest
On Error Resume Next
Application.ScreenUpdating = False
Wenn xFiles.Count > 0 dann

Für I = 1 bis xFiles.Count
Setze xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopieren nach:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close Falsch
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Für xFNum = 1 bis xIntRow
Setze xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Wenn UBound(xArr) > 0 dann
Für xFArr = 0 bis UBound(xArr)
Wenn xArr(xFArr) <> "" Dann
xRg.Wert = xArr(xFArr)
Setze xRg = xRg.Offset(ColumnOffset:=1)
End If
Weiter
End If
Weiter
Weiter
End If
Application.ScreenUpdating = True
End Sub

Sie können die Funktion Suchen und Ersetzen verwenden, um das Komma zuerst durch ein Leerzeichen zu ersetzen, und dann eine der obigen Methoden anwenden, um es in eine Excel-Datei zu konvertieren.

Wollen Sie alle Textdateien auf einem Blatt kombinieren?

Hallo, Davinder, Sie können den folgenden VBA-Code ausprobieren.

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

Ich habe diesen Code für mich gearbeitet, aber ich muss noch etwas daran ändern.

*Ich möchte, dass es auf demselben Blatt eingefügt wird, ohne ein neues Blatt zu öffnen, und es dann kopiert, da es länger dauert.

* Es muss eine Bedingung eingefügt werden, wenn importierte TXT-Dateien in Blatt 1 eingefügt werden, wenn sie mit Buchstabe A beginnen, und in Blatt 2 importiert werden, wenn sie mit Buchstabe B beginnen


Unter testcopy3()
Dim xWb als Arbeitsmappe
Dim xToBook als Arbeitsmappe
Dim xStrPath als Zeichenfolge
Dim xFileDialog As FileDialog
Dim xFile als Zeichenfolge
Dim xFiles als neue Sammlung
Dim ich als lang
Dim LastRow As Long
Dim Rng As Range
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Ordner auswählen [Kutools for Excel]"
Wenn xFileDialog.Show = -1 Dann
xStrPath = xFileDialog.SelectedItems(1)
End If
Wenn xStrPath = "" dann Sub beenden
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Wenn xFile = "" Dann
MsgBox "Keine Dateien gefunden", vbInformation, "Kutools für Excel"
Exit Sub
End If
Do While xFile <> ""
xFiles.Add xFile, xFile
xDatei = Dir()
Loop
Bereich ("N2").Auswählen
Legen Sie xToBook = DieseArbeitsmappe fest
Wenn xFiles.Count > 0 dann
Für i = 1 bis xFiles.Count
Setze xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Activate
'Textdaten auswählen und kopieren
Bereich (Auswahl, Auswahl.End (xlDown))
Auswahl.Kopieren
xToBook.Activate
ActiveSheet.Paste
Selection.End(xlDown).Offset(1).Select
On Error Resume Next
Bei Fehler GoTo 0
xWb.Close Falsch
Weiter
End If
End Sub

Tut mir leid, mir sind die Hände gebunden

Tut mir leid, Harsh, sei nur vorsichtig, um ein wiederholtes Importieren zu vermeiden.

Pooja, Sie können die Funktion Führende Nullen entfernen von Kutools for Excel ausprobieren, um alle führenden Nullen nach dem Importieren aus der Auswahl zu entfernen.

Wenn Sie die führenden Nullen beibehalten möchten, können Sie sie mit Cell Format als Textformat formatieren.

Hallo, versuchen Sie bitte den folgenden Code

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

Hallo, Daniel, versuchen Sie den folgenden Code, er importiert alle Textdateien in einem Blatt namens Txt.
Beachten Sie Folgendes: Wenn der Textname mit dem Namen des vorhandenen Blatts übereinstimmt, wird die Textdatei möglicherweise nicht importiert.

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