Wilt u de spatie (scheidingstekens) behouden na het converteren van de tekstbestanden naar bladen?

Zou je het tekstbestand en het gewenste resultaat voor mij kunnen uploaden?

Hallo, Des en PB Rama Murty, de onderstaande code kan gegevens in kolommen splitsen op basis van spatie of tab tijdens het importeren van een tekstbestand naar bladen. Je kunt het proberen.

Sub ImportTextToExcel()
'Bijwerken door'Extendoffice20180911
Dim xWb als werkmap
Dim xToBook als werkboek
Dim xStrPath als string
Dim xFileDialog als FileDialog
Dim xFile als string
Dim xFiles als nieuwe collectie
Dim ik zo lang
Dim xIntRow zo lang
Dim xFNum, xFArr Zo Lang
Dim xStrValue als tekenreeks
Dim xRg als bereik
Dim xArr
Stel xFileDialog = Application.FileDialog (msoFileDialogFolderPicker) in
xFileDialog.AllowMultiSelect = Onwaar
xFileDialog.Title = "Selecteer een map [Kutools for Excel]"
Als xFileDialog.Show = -1 Dan
xStrPath = xFileDialog.SelectedItems(1)
End If
Als xStrPath = "" Sub afsluiten
If Right(xStrPath, 1) <> "\" Dan xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Dan
MsgBox "Geen bestanden gevonden", vbInformation, "Kutools voor Excel"
Exit Sub
End If
Doen terwijl xFile <> ""
xFiles.Voeg xFile, xFile toe
xBestand = Dir()
Ringleiding
Stel xToBook = ThisWorkbook in
On Error Resume Next
Application.ScreenUpdating = False
Als xFiles.Count > 0 Dan

Voor I = 1 Naar xFiles.Count
Stel xWb = Workbooks.Open(xStrPath & xFiles.Item(I)) in
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Sluiten False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Voor xFNum = 1 Naar xIntRow
Stel xRg = ActiveSheet.Bereik in ("A" & xFNum)
xArr = Splitsen(xRg.Text, " ")
Als UBound(xArr) > 0 dan
Voor xFArr = 0 Naar UBound(xArr)
Als xArr(xFArr) <> "" Dan
xRg.Waarde = xArr(xFArr)
Set xRg = xRg.Offset(KolomOffset:=1)
End If
Volgende
End If
Volgende
Volgende
End If
Application.ScreenUpdating = True
End Sub

Welke wijzigingen moeten worden aangebracht als ik gegevens in kolommen moet plaatsen op basis van komma's?

Ik heb dit gebruikt en het werkt, maar ik zou graag willen dat alles op één blad wordt opgeslagen, aangezien elk blad dezelfde informatie bevat, het zijn gewoon logbestanden van elke dag.
dus ik moet de combineren
alle items in de map op één blad
Sub ImportCSVsWithReference()
'Updatedoor KutoolsforExcel20151214'
Dim xWb als werkmap
Dim xToBook als werkboek
Dim xStrPath als string
Dim xFileDialog als FileDialog
Dim xFile als string
Dim xFiles als nieuwe collectie
Dim ik zo lang
Dim xIntRow zo lang
Dim xFNum, xFArr Zo Lang
Dim xStrValue als tekenreeks
Dim xRg als bereik
Dim xArr
Bij fout Ga naar ErrHandler
Stel xFileDialog = Application.FileDialog (msoFileDialogFolderPicker) in
xFileDialog.AllowMultiSelect = Onwaar
xFileDialog.Title = "Selecteer een map [Kutools for Excel]"
Als xFileDialog.Show = -1 Dan
xStrPath = xFileDialog.SelectedItems(1)
End If
Als xStrPath = "" Sub afsluiten
If Right(xStrPath, 1) <> "\" Dan xStrPath = xStrPath & "\"
Stel xSht = ThisWorkbook.ActiveSheet in
If MsgBox ("Wis het bestaande blad voordat u importeert?", vbYesNo, "Kutools for Excel") = vbYes Dan xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
Doen terwijl xFile <> ""
Stel xWb = Workbooks.Open in (xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Sluiten False
xBestand = Dir
Ringleiding
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "geen txt-bestanden", "Kutools voor Excel"
End Sub

en deze die spaties gebruikt om aan elke kolom toe te voegen

Sub ImportTextToExcel()
'Bijwerken door'Extendoffice20180911
Dim xWb als werkmap
Dim xToBook als werkboek
Dim xStrPath als string
Dim xFileDialog als FileDialog
Dim xFile als string
Dim xFiles als nieuwe collectie
Dim ik zo lang
Dim xIntRow zo lang
Dim xFNum, xFArr Zo Lang
Dim xStrValue als tekenreeks
Dim xRg als bereik
Dim xArr
Stel xFileDialog = Application.FileDialog (msoFileDialogFolderPicker) in
xFileDialog.AllowMultiSelect = Onwaar
xFileDialog.Title = "Selecteer een map [Kutools for Excel]"
Als xFileDialog.Show = -1 Dan
xStrPath = xFileDialog.SelectedItems(1)
End If
Als xStrPath = "" Sub afsluiten
If Right(xStrPath, 1) <> "\" Dan xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Dan
MsgBox "Geen bestanden gevonden", vbInformation, "Kutools voor Excel"
Exit Sub
End If
Doen terwijl xFile <> ""
xFiles.Voeg xFile, xFile toe
xBestand = Dir()
Ringleiding
Stel xToBook = ThisWorkbook in
On Error Resume Next
Application.ScreenUpdating = False
Als xFiles.Count > 0 Dan

Voor I = 1 Naar xFiles.Count
Stel xWb = Workbooks.Open(xStrPath & xFiles.Item(I)) in
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Sluiten False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Voor xFNum = 1 Naar xIntRow
Stel xRg = ActiveSheet.Bereik in ("A" & xFNum)
xArr = Splitsen(xRg.Text, " ")
Als UBound(xArr) > 0 dan
Voor xFArr = 0 Naar UBound(xArr)
Als xArr(xFArr) <> "" Dan
xRg.Waarde = xArr(xFArr)
Set xRg = xRg.Offset(KolomOffset:=1)
End If
Volgende
End If
Volgende
Volgende
End If
Application.ScreenUpdating = True
End Sub

U kunt Zoeken en vervangen fuctuon gebruiken om de komma eerst door spatie te vervangen en een van de bovenstaande methoden toepassen om deze naar een Excel-bestand te converteren.

Bedoel je het combineren van alle tekstbestanden op één blad?

Hallo, Davinder, je kunt onderstaande vba-code proberen.

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

Ik heb deze code voor mij gewerkt, maar toch moet ik er wat in veranderen.

*Ik wil dat het op hetzelfde blad wordt geplakt zonder een nieuw blad te openen en het vervolgens te kopiëren omdat het langer duurt.

*moet een voorwaarde invoegen als geïmporteerde txt-bestanden op blad 1 moeten worden geplakt als het begint met de letter A en geïmporteerd in blad 2 als het begint met de letter B


Subtestkopie3()
Dim xWb als werkmap
Dim xToBook als werkboek
Dim xStrPath als string
Dim xFileDialog als FileDialog
Dim xFile als string
Dim xFiles als nieuwe collectie
Dim ik zo lang
Dim LaatsteRij Zo Lang
Dim Rng als bereik
Stel xFileDialog = Application.FileDialog (msoFileDialogFolderPicker) in
xFileDialog.AllowMultiSelect = Onwaar
xFileDialog.Title = "Selecteer een map [Kutools for Excel]"
Als xFileDialog.Show = -1 Dan
xStrPath = xFileDialog.SelectedItems(1)
End If
Als xStrPath = "" Sub afsluiten
If Right(xStrPath, 1) <> "\" Dan xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Dan
MsgBox "Geen bestanden gevonden", vbInformation, "Kutools voor Excel"
Exit Sub
End If
Doen terwijl xFile <> ""
xFiles.Voeg xFile, xFile toe
xBestand = Dir()
Ringleiding
Bereik ("N2"). Selecteer
Stel xToBook = ThisWorkbook in
Als xFiles.Count > 0 Dan
Voor i = 1 Naar xFiles.Count
Stel xWb = Workbooks.Open(xStrPath & xFiles.Item(i)) in
xWb.Activeren
'Selecteren en kopiëren van de txt-gegevens'
Bereik(Selectie, Selectie.End(xlOmlaag)).Selecteren
Selection.Copy
xToBook.Activeren
ActiveSheet.Paste
Selectie.Einde(xlOmlaag).Offset(1).Selecteren
On Error Resume Next
On Error GoTo 0
xWb.Sluiten False
Volgende
End If
End Sub

Sorry, mijn handen zijn gebonden

Sorry, Harsh, pas op dat u niet herhaaldelijk importeert.

Pooja, je kunt de Verwijder voorloopnullen functie van Kutools for Excel proberen om alle voorloopnullen uit de selectie te verwijderen na het importeren.

Als u de voorloopnullen wilt behouden, kunt u ze opmaken als tekstformaat met Celopmaak.

Hallo, probeer a.u.b. onderstaande 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, probeer onderstaande code, het importeert alle tekstbestanden in één blad met de naam Txt.
Merk op dat: als de tekstnaam hetzelfde is als de bestaande bladnaam, het tekstbestand mogelijk niet wordt geïmporteerd.

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