Θέλετε να διατηρήσετε το διάστημα (οριοθέτες) μετά τη μετατροπή των αρχείων κειμένου σε φύλλα;

Θα μπορούσατε να ανεβάσετε το αρχείο κειμένου και το αποτέλεσμα που θέλετε για μένα;

Γεια σας, Des και PB Rama Murty, ο παρακάτω κώδικας μπορεί να χωρίσει τα δεδομένα σε στήλες με βάση το διάστημα ή την καρτέλα κατά την εισαγωγή αρχείου κειμένου σε φύλλα. Μπορείτε να δοκιμάσετε.

Sub ImportTextToExcel()
'ΕνημέρωσηExtendoffice20180911
Dim xWb ως βιβλίο εργασίας
Dim xToBook ως βιβλίο εργασίας
Dim xStrPath ως συμβολοσειρά
Dim xFileDialog ως FileDialog
Dim xFile ως συμβολοσειρά
Dim xFiles ως νέα συλλογή
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ως συμβολοσειρά
Dim xRg ως εύρος
Dim xArr
Ορισμός xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Επιλέξτε έναν φάκελο [Kutools for Excel]"
Αν xFileDialog.Show = -1 Τότε
xStrPath = xFileDialog.SelectedItems(1)
End If
Αν xStrPath = "" Τότε βγείτε από το Sub
If Right(xStrPath, 1) <> "\" Τότε xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Αν xFile = "" Τότε
MsgBox "Δεν βρέθηκαν αρχεία", vbInformation, "Kutools for Excel"
Έξοδος Sub
End If
Do while xFile <> ""
xFiles.Προσθήκη xFile, xFile
xFile = Dir()
Βρόχος
Ορισμός xToBook = This Workbook
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Αν xFiles.Count > 0 Τότε

Για I = 1 To xFiles.Count
Ορισμός xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Αντιγραφή μετά:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Κλείσιμο False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Για xFNum = 1 έως xIntRow
Ορισμός xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Αν UBound(xArr) > 0 Τότε
Για xFArr = 0 To UBound(xArr)
Αν xArr(xFArr) <> "" Τότε
xRg.Value = xArr(xFArr)
Ορισμός xRg = xRg.Offset(ColumnOffset:=1)
End If
Επόμενο
End If
Επόμενο
Επόμενο
End If
Application.ScreenUpdating = True
Sub End

Ποιες αλλαγές πρέπει να γίνουν εάν χρειάζομαι συνολικά δεδομένα σε στήλες με κόμμα;

Το χρησιμοποίησα αυτό και λειτουργεί, αλλά θα ήθελα να αποθηκευτούν όλα σε ένα φύλλο καθώς κάθε φύλλο είναι οι ίδιες πληροφορίες, είναι απλώς αρχεία καταγραφής από κάθε μέρα.
οπότε πρέπει να συνδυάσω το
όλα τα στοιχεία του φακέλου σε ένα φύλλο
Sub ImportCSVsWithReference()
«Ενημέρωση με KutoolsforExcel20151214
Dim xWb ως βιβλίο εργασίας
Dim xToBook ως βιβλίο εργασίας
Dim xStrPath ως συμβολοσειρά
Dim xFileDialog ως FileDialog
Dim xFile ως συμβολοσειρά
Dim xFiles ως νέα συλλογή
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ως συμβολοσειρά
Dim xRg ως εύρος
Dim xArr
Σφάλμα Μετάβαση στο ErrHandler
Ορισμός xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Επιλέξτε έναν φάκελο [Kutools for Excel]"
Αν xFileDialog.Show = -1 Τότε
xStrPath = xFileDialog.SelectedItems(1)
End If
Αν xStrPath = "" Τότε βγείτε από το Sub
If Right(xStrPath, 1) <> "\" Τότε xStrPath = xStrPath & "\"
Ορίστε xSht = ThisWorkbook.ActiveSheet
Αν MsgBox("Εκκαθάριση του υπάρχοντος φύλλου πριν από την εισαγωγή;", vbYesNo, "Kutools for Excel") = vbYes Τότε xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
Do while xFile <> ""
Ορισμός xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Κλείσιμο False
xFile = Σκην
Βρόχος
Application.ScreenUpdating = True
Έξοδος Sub
ErrHandler:
MsgBox "χωρίς αρχεία txt", , "Kutools for Excel"
Sub End

και αυτό που χρησιμοποιεί κενά για dd σε κάθε στήλη

Sub ImportTextToExcel()
'ΕνημέρωσηExtendoffice20180911
Dim xWb ως βιβλίο εργασίας
Dim xToBook ως βιβλίο εργασίας
Dim xStrPath ως συμβολοσειρά
Dim xFileDialog ως FileDialog
Dim xFile ως συμβολοσειρά
Dim xFiles ως νέα συλλογή
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ως συμβολοσειρά
Dim xRg ως εύρος
Dim xArr
Ορισμός xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Επιλέξτε έναν φάκελο [Kutools for Excel]"
Αν xFileDialog.Show = -1 Τότε
xStrPath = xFileDialog.SelectedItems(1)
End If
Αν xStrPath = "" Τότε βγείτε από το Sub
If Right(xStrPath, 1) <> "\" Τότε xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Αν xFile = "" Τότε
MsgBox "Δεν βρέθηκαν αρχεία", vbInformation, "Kutools for Excel"
Έξοδος Sub
End If
Do while xFile <> ""
xFiles.Προσθήκη xFile, xFile
xFile = Dir()
Βρόχος
Ορισμός xToBook = This Workbook
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Αν xFiles.Count > 0 Τότε

Για I = 1 To xFiles.Count
Ορισμός xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Αντιγραφή μετά:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Κλείσιμο False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Για xFNum = 1 έως xIntRow
Ορισμός xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Αν UBound(xArr) > 0 Τότε
Για xFArr = 0 To UBound(xArr)
Αν xArr(xFArr) <> "" Τότε
xRg.Value = xArr(xFArr)
Ορισμός xRg = xRg.Offset(ColumnOffset:=1)
End If
Επόμενο
End If
Επόμενο
Επόμενο
End If
Application.ScreenUpdating = True
Sub End

Μπορείτε να χρησιμοποιήσετε το Fuctuon Find and Replace για να αντικαταστήσετε πρώτα το κόμμα με κενό και να εφαρμόσετε μία από τις παραπάνω μεθόδους για να το μετατρέψετε σε αρχείο Excel.

Εννοείτε να συνδυάσετε όλο το αρχείο κειμένου σε ένα φύλλο;

Γεια, Davinder, μπορείς να δοκιμάσεις τον παρακάτω κώδικα 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

Αυτός ο κωδικός λειτούργησε για μένα, αλλά και πάλι, πρέπει να αλλάξω μερικούς σε αυτόν.

*Θέλω να γίνει επικόλληση στο ίδιο φύλλο χωρίς να ανοίξει νέο φύλλο και μετά να το αντιγράψω καθώς χρειάζεται περισσότερος χρόνος.

*πρέπει να εισαγάγετε ένα υπό όρους εάν για αρχεία txt που εισάγονται για επικόλληση στο φύλλο 1 εάν ξεκινά με γράμμα Α και εισάγεται στο φύλλο 2 εάν ξεκινά με γράμμα Β


Δευτερεύον δοκιμαστικό αντίγραφο3()
Dim xWb ως βιβλίο εργασίας
Dim xToBook ως βιβλίο εργασίας
Dim xStrPath ως συμβολοσειρά
Dim xFileDialog ως FileDialog
Dim xFile ως συμβολοσειρά
Dim xFiles ως νέα συλλογή
Dim i As Long
Dim LastRow As Long
Dim Rng ως εμβέλεια
Ορισμός xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Επιλέξτε έναν φάκελο [Kutools for Excel]"
Αν xFileDialog.Show = -1 Τότε
xStrPath = xFileDialog.SelectedItems(1)
End If
Αν xStrPath = "" Τότε βγείτε από το Sub
If Right(xStrPath, 1) <> "\" Τότε xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Αν xFile = "" Τότε
MsgBox "Δεν βρέθηκαν αρχεία", vbInformation, "Kutools for Excel"
Έξοδος Sub
End If
Do while xFile <> ""
xFiles.Προσθήκη xFile, xFile
xFile = Dir()
Βρόχος
Εύρος ("N2"). Επιλέξτε
Ορισμός xToBook = This Workbook
Αν xFiles.Count > 0 Τότε
Για i = 1 To xFiles.Count
Ορισμός xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Ενεργοποίηση
«Επιλογή και αντιγραφή των δεδομένων txt
Εύρος (επιλογή, επιλογή.ενός (xlDown))
Selection.Copy
xToBook.Ενεργοποίηση
ActiveSheet.Paste
Επιλογή.Τέλος(xlDown).Offset(1).Επιλογή
On Error Συνέχιση Επόμενη
Στο σφάλμα GoTo 0
xWb.Κλείσιμο False
Επόμενο
End If
Sub End

Συγγνώμη, τα χέρια μου είναι δεμένα

Συγγνώμη, Σκληρός, απλά να είστε προσεκτικοί για να αποφύγετε την επανειλημμένη εισαγωγή.

Pooja, μπορείτε να δοκιμάσετε τη λειτουργία Remove Leading Zeros του Kutools για Excel για να αφαιρέσετε όλα τα κύρια μηδενικά από την επιλογή μετά την εισαγωγή.

Εάν θέλετε να διατηρήσετε τα μηδενικά που προηγούνται, μπορείτε να τα μορφοποιήσετε ως μορφή κειμένου ανά Μορφή κελιού.

Γεια, δοκιμάστε τον παρακάτω κώδικα

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

Γεια, Daniel, δοκιμάστε τον παρακάτω κώδικα, εισάγει όλα τα αρχεία κειμένου σε ένα φύλλο που ονομάζεται Txt.
Σημειώστε ότι: εάν το όνομα κειμένου είναι ίδιο με το όνομα του φύλλου που έχετε ήδη, το αρχείο κειμένου ενδέχεται να μην εισαχθεί.

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