Czy chcesz zachować spację (ograniczniki) po konwersji plików tekstowych na arkusze?

Czy możesz przesłać plik tekstowy i wynik, który chcesz dla mnie?

Witam, Des i PB Rama Murty, poniższy kod potrafi podzielić dane na kolumny w oparciu o spację lub tabulator podczas importowania pliku tekstowego do arkuszy. Możesz spróbować.

Sub ImportTextToExcel()
„Aktualizuj do”Extendoffice20180911
Dim xWb jako skoroszyt
Dim xToBook jako skoroszyt
Dim xStrPath jako ciąg
Dim xFileDialog jako FileDialog
Dim xFile jako ciąg
Dim xFiles jako nowa kolekcja
Dim I tak długo
Dim xIntRow tak długo
Wym. xFNum, xFArr Tak długo
Dim xStrValue jako ciąg
Dim xRg jako zakres
Przyciemnij xArr
Ustaw xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fałsz
xFileDialog.Title = "Wybierz folder [Kutools for Excel]"
Jeśli xFileDialog.Show = -1 Wtedy
xStrPath = xFileDialog.SelectedItems(1)
End If
Jeśli xStrPath = "" Następnie wyjdź z Sub
Jeśli Right(xStrPath, 1) <> "\" Wtedy xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Jeśli xFile = „” Wtedy
MsgBox "Nie znaleziono plików", vbInformation, "Kutools for Excel"
Exit Sub
End If
Rób, gdy xFile <> ""
xFiles.Dodaj xFile, xFile
xPlik = Katalog()
Pętla
Ustaw xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = Fałsz
Jeśli xFiles.Count > 0 Wtedy

Dla I = 1 To xFiles.Count
Ustaw xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiuj po:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Nazwa

xWb.Zamknij Fałsz
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Dla xFNum = 1 do xIntRow
Ustaw xRg = ActiveSheet.Range("A" i xFNum)
xArr = Podziel (xRg.Tekst, " ")
Jeśli UBound(xArr) > 0 Wtedy
Dla xFArr = 0 To UBound(xArr)
Jeśli xArr(xFArr) <> "" Wtedy
xRg.Wartość = xArr(xFArr)
Ustaw xRg = xRg.Przesunięcie(Przesunięcie kolumny:=1)
End If
Dalej
End If
Dalej
Dalej
End If
Application.ScreenUpdating = True
End Sub

Jakie zmiany należy wprowadzić, jeśli muszę zsumować dane w kolumnach na podstawie przecinka?

Użyłem tego i działa, ale chciałbym, aby wszystko zostało zapisane w jednym arkuszu, ponieważ każdy arkusz zawiera te same informacje, które są tylko plikami dziennika z każdego dnia.
więc muszę połączyć
wszystkie elementy w folderze na jednym arkuszu
Sub Import CSVsWithReference()
„Aktualizacja przez Kutools dla programu Excel20151214”
Dim xWb jako skoroszyt
Dim xToBook jako skoroszyt
Dim xStrPath jako ciąg
Dim xFileDialog jako FileDialog
Dim xFile jako ciąg
Dim xFiles jako nowa kolekcja
Dim I tak długo
Dim xIntRow tak długo
Wym. xFNum, xFArr Tak długo
Dim xStrValue jako ciąg
Dim xRg jako zakres
Przyciemnij xArr
W przypadku błędu przejdź do obsługi błędów
Ustaw xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fałsz
xFileDialog.Title = "Wybierz folder [Kutools for Excel]"
Jeśli xFileDialog.Show = -1 Wtedy
xStrPath = xFileDialog.SelectedItems(1)
End If
Jeśli xStrPath = "" Następnie wyjdź z Sub
Jeśli Right(xStrPath, 1) <> "\" Wtedy xStrPath = xStrPath & "\"
Ustaw xSht = ThisWorkbook.ActiveSheet
If MsgBox("Wyczyścić istniejący arkusz przed importowaniem?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = Fałsz
xFile = Dir(xStrPath & "\" & "*.log")
Rób, gdy xFile <> ""
Ustaw xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Zamknij Fałsz
xPlik = Katalog
Pętla
Application.ScreenUpdating = True
Exit Sub
Obsługa błędów:
MsgBox "brak plików txt", , "Kutools for Excel"
End Sub

i ten, który używa spacji do dd do każdej kolumny

Sub ImportTextToExcel()
„Aktualizuj do”Extendoffice20180911
Dim xWb jako skoroszyt
Dim xToBook jako skoroszyt
Dim xStrPath jako ciąg
Dim xFileDialog jako FileDialog
Dim xFile jako ciąg
Dim xFiles jako nowa kolekcja
Dim I tak długo
Dim xIntRow tak długo
Wym. xFNum, xFArr Tak długo
Dim xStrValue jako ciąg
Dim xRg jako zakres
Przyciemnij xArr
Ustaw xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fałsz
xFileDialog.Title = "Wybierz folder [Kutools for Excel]"
Jeśli xFileDialog.Show = -1 Wtedy
xStrPath = xFileDialog.SelectedItems(1)
End If
Jeśli xStrPath = "" Następnie wyjdź z Sub
Jeśli Right(xStrPath, 1) <> "\" Wtedy xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Jeśli xFile = „” Wtedy
MsgBox "Nie znaleziono plików", vbInformation, "Kutools for Excel"
Exit Sub
End If
Rób, gdy xFile <> ""
xFiles.Dodaj xFile, xFile
xPlik = Katalog()
Pętla
Ustaw xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = Fałsz
Jeśli xFiles.Count > 0 Wtedy

Dla I = 1 To xFiles.Count
Ustaw xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiuj po:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Nazwa

xWb.Zamknij Fałsz
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Dla xFNum = 1 do xIntRow
Ustaw xRg = ActiveSheet.Range("A" i xFNum)
xArr = Podziel (xRg.Tekst, " ")
Jeśli UBound(xArr) > 0 Wtedy
Dla xFArr = 0 To UBound(xArr)
Jeśli xArr(xFArr) <> "" Wtedy
xRg.Wartość = xArr(xFArr)
Ustaw xRg = xRg.Przesunięcie(Przesunięcie kolumny:=1)
End If
Dalej
End If
Dalej
Dalej
End If
Application.ScreenUpdating = True
End Sub

Możesz użyć funkcji Znajdź i zamień, aby najpierw zastąpić przecinek spacją, a następnie zastosować jedną z powyższych metod, aby przekonwertować go na plik Excel.

Czy masz na myśli połączenie całego pliku tekstowego w jeden arkusz?

Cześć, Davinder, możesz wypróbować poniższy kod vba.

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

Ten kod zadziałał dla mnie, ale nadal muszę w nim coś zmienić.

*Chcę go wkleić na tym samym arkuszu bez otwierania nowego arkusza, a następnie skopiować, ponieważ zajmuje to więcej czasu.

*należy wstawić warunek, jeśli importowane pliki txt mają być wklejone na arkuszu 1, jeśli zaczyna się na literę A i importowane do arkusza 2, jeśli zaczyna się na literę B


Pod kopia testowa3()
Dim xWb jako skoroszyt
Dim xToBook jako skoroszyt
Dim xStrPath jako ciąg
Dim xFileDialog jako FileDialog
Dim xFile jako ciąg
Dim xFiles jako nowa kolekcja
Przyciemnij i tak długo
Dim LastRow tak długo
Dim Rng jako zakres
Ustaw xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fałsz
xFileDialog.Title = "Wybierz folder [Kutools for Excel]"
Jeśli xFileDialog.Show = -1 Wtedy
xStrPath = xFileDialog.SelectedItems(1)
End If
Jeśli xStrPath = "" Następnie wyjdź z Sub
Jeśli Right(xStrPath, 1) <> "\" Wtedy xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Jeśli xFile = „” Wtedy
MsgBox "Nie znaleziono plików", vbInformation, "Kutools for Excel"
Exit Sub
End If
Rób, gdy xFile <> ""
xFiles.Dodaj xFile, xFile
xPlik = Katalog()
Pętla
Zakres ("N2"). Wybierz
Ustaw xToBook = ThisWorkbook
Jeśli xFiles.Count > 0 Wtedy
Dla i = 1 To xFiles.Count
Ustaw xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Aktywuj
'Wybieranie i kopiowanie danych txt'
Zakres (Wybór, Wybór. Koniec (xlDown)). Wybierz
Selection.Copy
xToBook.Aktywuj
ActiveSheet.Paste
Wybór.Koniec(xlDown).Przesunięcie(1).Wybierz
On Error Resume Next
Przy błędzie GoTo 0
xWb.Zamknij Fałsz
Dalej
End If
End Sub

Przepraszam, mam związane ręce

Przepraszam, szorstko, po prostu uważaj, aby uniknąć wielokrotnego importowania.

Pooja, możesz wypróbować funkcję Usuń wiodące zera w Kutools dla programu Excel, aby usunąć wszystkie wiodące zera z zaznaczenia po zaimportowaniu.

Jeśli chcesz zachować wiodące zera, możesz je sformatować jako format tekstowy według formatu komórki.

Cześć, wypróbuj poniższy kod

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

Cześć, Daniel, wypróbuj poniższy kod, importuje wszystkie pliki tekstowe w jednym arkuszu o nazwie Txt.
Uwaga: jeśli nazwa tekstu jest taka sama jak nazwa istniejącego arkusza, plik tekstowy może nie zostać zaimportowany.

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