Vill du behålla utrymmet (avgränsare) efter att du har konverterat textfilerna till ark?

Kan du ladda upp textfilen och resultatet du vill ha för mig?

Hej, Des och PB Rama Murty, koden nedan kan dela upp data i kolumner baserat på mellanslag eller tabb medan textfil importeras till ark. Du kan göra ett försök.

Sub ImportTextToExcel()
'Uppdatering avExtendoffice20180911
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Om xFile = "" Då
MsgBox "Inga filer hittades", vbInformation, "Kutools för Excel"
Exit Sub
End If
Gör medan xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
loop
Ställ in xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Om xFiles.Count > 0 Då

För I = 1 Till xFiles.Count
Ställ in xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiera efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Stäng Falskt
xIntRow = ActiveCell.CurrentRegion.Rows.Count
För xFNum = 1 Till xIntRow
Ställ in xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Om UBound(xArr) > 0 Då
För xFArr = 0 Till UBound(xArr)
Om xArr(xFArr) <> "" Då
xRg.Value = xArr(xFArr)
Ställ in xRg = xRg.Offset(ColumnOffset:=1)
End If
Nästa
End If
Nästa
Nästa
End If
Application.ScreenUpdating = True
End Sub

Vilka ändringar behöver göras om jag behöver samla data i kolumner baserade på kommatecken?

Jag använde detta och det fungerar men jag skulle vilja att allt sparas på ett ark eftersom varje ark är samma information, de är bara loggfiler från varje dag.
så jag måste kombinera
alla objekt i mappen till ett ark
Sub ImportCSVsWithReference()
'Uppdatering av KutoolforExcel20151214
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Vid fel GoTo ErrHandler
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
Ställ in xSht = ThisWorkbook.ActiveSheet
Om MsgBox("Rensa det befintliga arket innan du importerar?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
Gör medan xFile <> ""
Ställ in xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Stäng Falskt
xFile = Dir
loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "inga txt-filer", , "Kutools för Excel"
End Sub

och den här som använder mellanslag för att lägga till varje kolumn

Sub ImportTextToExcel()
'Uppdatering avExtendoffice20180911
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Om xFile = "" Då
MsgBox "Inga filer hittades", vbInformation, "Kutools för Excel"
Exit Sub
End If
Gör medan xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
loop
Ställ in xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Om xFiles.Count > 0 Då

För I = 1 Till xFiles.Count
Ställ in xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiera efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Stäng Falskt
xIntRow = ActiveCell.CurrentRegion.Rows.Count
För xFNum = 1 Till xIntRow
Ställ in xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Om UBound(xArr) > 0 Då
För xFArr = 0 Till UBound(xArr)
Om xArr(xFArr) <> "" Då
xRg.Value = xArr(xFArr)
Ställ in xRg = xRg.Offset(ColumnOffset:=1)
End If
Nästa
End If
Nästa
Nästa
End If
Application.ScreenUpdating = True
End Sub

Du kan använda Sök och ersätt fuctuon för att ersätta kommatecken med blanksteg först, och tillämpa en av ovanstående metoder för att konvertera den till Excel-fil.

Menar du att kombinera all textfil till ett ark?

Hej, Davinder, du kan prova nedan vba-kod.

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

Jag har den här koden fungerat för mig men ändå måste jag ändra en del i den.

*Jag vill att det ska klistra in på samma ark utan att öppna ett nytt ark och sedan kopiera det eftersom det tar längre tid.

*måste infoga ett villkorligt if för importerade txt-filer för att klistras in på blad 1 om det börjar med bokstaven A och importeras till blad 2 om det börjar med bokstaven B


Sub testcopy3()
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim jag så länge
Dimma Last Row As Long
Dim Rng som intervall
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Om xFile = "" Då
MsgBox "Inga filer hittades", vbInformation, "Kutools för Excel"
Exit Sub
End If
Gör medan xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
loop
Range("N2"). Välj
Ställ in xToBook = ThisWorkbook
Om xFiles.Count > 0 Då
För i = 1 Till xFiles.Count
Ställ in xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Aktivera
'Välja och kopiera txt-data
Range(Selection, Selection.End(xlDown)).Välj
Selection.Copy
xToBook.Aktivera
ActiveSheet.Paste
Selection.End(xlDown).Offset(1).Välj
On Error Resume Next
På Fel GoTo 0
xWb.Stäng Falskt
Nästa
End If
End Sub

Förlåt, mina händer är bundna

Förlåt, Harsh, var bara försiktig så att du undviker att importera upprepade gånger.

Pooja, du kan prova funktionen Ta bort ledande nollor i Kutools för Excel för att ta bort alla inledande nollor från urvalet efter import.

Om du vill behålla de inledande nollorna kan du formatera dem som textformat med cellformat.

Hej, försök koden nedan

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

Hej, Daniel, försök nedanstående kod, den importerar alla textfiler i ett ark som heter Txt.
Observera att: om textnamnet är detsamma som det befintliga arknamnet kanske textfilen inte importeras.

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