Vil du beholde mellemrummet (afgrænserne) efter konvertering af tekstfilerne til ark?

Kunne du uploade tekstfilen og det resultat, du ønsker for mig?

Hej, Des og PB Rama Murty, nedenstående kode kan opdele data i kolonner baseret på mellemrum eller tabulator, mens tekstfil importeres til ark. Du kan prøve.

Sub ImportTextToExcel()
'Opdatering afExtendoffice20180911
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I Så længe
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Hvis xFile = "" Så
MsgBox "Ingen filer fundet", vbInformation, "Kutools til Excel"
Exit Sub
End If
Gør mens xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Indstil xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Hvis xFiles.Count > 0 Så

For I = 1 Til xFiles.Count
Indstil xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopier efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Luk Falsk
xIntRow = ActiveCell.CurrentRegion.Rows.Count
For xFNum = 1 Til xIntRow
Indstil xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Hvis UBound(xArr) > 0 Så
For xFArr = 0 Til UBound(xArr)
Hvis xArr(xFArr) <> "" Så
xRg.Value = xArr(xFArr)
Indstil xRg = xRg.Offset(ColumnOffset:=1)
End If
Næste
End If
Næste
Næste
End If
Application.ScreenUpdating = True
End Sub

Hvilke ændringer skal der foretages, hvis jeg har brug for data i kolonner baseret på komma?

Jeg brugte dette, og det virker, men jeg vil gerne have det hele til at gemme på ét ark, da hvert ark er den samme information, de er bare logfiler fra hver dag.
så jeg skal kombinere
alle elementer i mappen til ét ark
Sub ImportCSVsWithReference()
'Opdatering af KutoolforExcel20151214
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I Så længe
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Ved fejl Gå til ErrHandler
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
Indstil xSht = ThisWorkbook.ActiveSheet
Hvis MsgBox("Ryd det eksisterende ark før import?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
Gør mens xFile <> ""
Indstil xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Luk Falsk
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "ingen txt-filer", , "Kutools til Excel"
End Sub

og denne, der bruger mellemrum til at tilføje til hver kolonne

Sub ImportTextToExcel()
'Opdatering afExtendoffice20180911
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I Så længe
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Hvis xFile = "" Så
MsgBox "Ingen filer fundet", vbInformation, "Kutools til Excel"
Exit Sub
End If
Gør mens xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Indstil xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Hvis xFiles.Count > 0 Så

For I = 1 Til xFiles.Count
Indstil xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopier efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Luk Falsk
xIntRow = ActiveCell.CurrentRegion.Rows.Count
For xFNum = 1 Til xIntRow
Indstil xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Hvis UBound(xArr) > 0 Så
For xFArr = 0 Til UBound(xArr)
Hvis xArr(xFArr) <> "" Så
xRg.Value = xArr(xFArr)
Indstil xRg = xRg.Offset(ColumnOffset:=1)
End If
Næste
End If
Næste
Næste
End If
Application.ScreenUpdating = True
End Sub

Du kan bruge Find og Erstat fuctuon til at erstatte kommaet med mellemrum først, og anvende en af ​​ovenstående metoder til at konvertere det til Excel-fil.

Mener du at kombinere al tekstfil til ét ark?

Hej, Davinder, du kan prøve nedenstående vba-kode.

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

Jeg har fået denne kode til at fungere for mig, men jeg er stadig nødt til at ændre noget i den.

*Jeg vil have det til at indsætte på det samme ark uden at åbne et nyt ark og derefter kopiere det, da det tager længere tid.

*skal indsætte et betinget if for importerede txt-filer, der skal indsættes på ark 1, hvis det starter med bogstavet A og importeres til ark 2, hvis det starter med bogstavet B


Sub testcopy3()
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim jeg så længe
Dim Last Row As Long
Dim Rng Som Range
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Hvis xFile = "" Så
MsgBox "Ingen filer fundet", vbInformation, "Kutools til Excel"
Exit Sub
End If
Gør mens xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Range("N2"). Vælg
Indstil xToBook = ThisWorkbook
Hvis xFiles.Count > 0 Så
For i = 1 Til xFiles.Count
Indstil xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Aktiver
'Valg og kopiering af txt-data
Range(Udvalg, Valg.End(xlNed)).Vælg
Selection.Copy
xToBook.Activate
ActiveSheet.Paste
Selection.End(xlDown).Offset(1).Vælg
On Error Resume Next
På Fejl GoTo 0
xWb.Luk Falsk
Næste
End If
End Sub

Undskyld, mine hænder er bundet

Beklager, hård, bare vær forsigtig med at undgå gentagne importer.

Pooja, du kan prøve funktionen Fjern ledende nuller i Kutools for Excel for at fjerne alle ledende nuller fra markeringen efter import.

Hvis du vil beholde de foranstillede nuller, kan du formatere dem som tekstformat med celleformat.

Hej, prøv venligst nedenstående kode

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, prøv nedenstående kode, den importerer alle tekstfiler i et ark med navnet Txt.
Bemærk: Hvis tekstnavnet er det samme som det eksisterende arknavn, importeres tekstfilen muligvis ikke.

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