Note: The other languages of the website are Google-translated. Back to English

Πώς να εισαγάγετε πολλά αρχεία κειμένου από ένα φάκελο σε ένα φύλλο εργασίας;

Για περιπτώσεις, εδώ έχετε έναν φάκελο με πολλά αρχεία κειμένου, αυτό που θέλετε να κάνετε είναι να εισαγάγετε αυτά τα αρχεία κειμένου σε ένα μόνο φύλλο εργασίας, όπως φαίνεται παρακάτω. Αντί να αντιγράφετε τα αρχεία κειμένου ένα προς ένα, υπάρχουν κόλπα για γρήγορη εισαγωγή των αρχείων κειμένου από έναν φάκελο σε ένα φύλλο;

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

Εισαγωγή αρχείου κειμένου στο ενεργό κελί με το Kutools για Excel καλή ιδέα3


Εδώ είναι ένας κωδικός VBA που μπορεί να σας βοηθήσει να εισαγάγετε όλα τα αρχεία κειμένου από έναν συγκεκριμένο φάκελο σε ένα νέο φύλλο.

1. Ενεργοποιήστε ένα βιβλίο εργασίας που θέλετε να εισαγάγετε αρχεία κειμένου και πατήστε Alt + F11 πλήκτρα για ενεργοποίηση Microsoft Visual Basic για εφαρμογές παράθυρο.

2. κλικ Κύριο θέμα > Μονάδα μέτρησης, αντιγράψτε και επικολλήστε κάτω από τον κώδικα VBA στο Μονάδα μέτρησης παράθυρο.

VBA: Εισαγωγή πολλαπλών αρχείων κειμένου από έναν φάκελο σε ένα φύλλο

Sub Test()
'UpdatebyExtendoffice6/7/2016
    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
    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
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

3. Τύπος F5 για να εμφανιστεί ένα παράθυρο διαλόγου και επιλέξτε ένα φάκελο που περιέχει αρχεία κειμένου που θέλετε να εισαγάγετε. Δείτε το στιγμιότυπο οθόνης:
doc εισαγάγετε αρχεία κειμένου από ένα φάκελο 1

4. κλικ OK. Στη συνέχεια, τα αρχεία κειμένου έχουν εισαχθεί στο ενεργό βιβλίο εργασίας ως νέο φύλλο ξεχωριστά.
doc εισαγάγετε αρχεία κειμένου από ένα φάκελο 2


Εάν θέλετε να εισαγάγετε ένα αρχείο κειμένου σε ένα συγκεκριμένο κελί ή εύρος, μπορείτε να υποβάλετε αίτηση Kutools για Excel'S Εισαγωγή αρχείου στο δρομέα χρησιμότητα.

Kutools για Excel, με περισσότερα από 300 εύχρηστες λειτουργίες, διευκολύνει τις εργασίες σας. 

Μετά το δωρεάν εγκατάσταση Kutools για Excel, κάντε τα παρακάτω:

1. Επιλέξτε ένα κελί που θέλετε να εισαγάγετε το αρχείο κειμένου και κάντε κλικ στο Kutools Plus > Εισαγωγή εξαγωγή > Εισαγωγή αρχείου στο δρομέα. Δείτε το στιγμιότυπο οθόνης:
doc εισαγάγετε αρχεία κειμένου από ένα φάκελο 3

2. Στη συνέχεια, εμφανίζεται ένας διάλογος, κάντε κλικ στο Αναζήτηση για να εμφανιστεί το Επιλέξτε ένα αρχείο για εισαγωγή στο παράθυρο διαλόγου θέσης του δρομέα κελιού, στη συνέχεια επιλέξτε Αρχεία κειμένου από την αναπτυσσόμενη λίστα και, στη συνέχεια, επιλέξτε το αρχείο κειμένου που θέλετε να εισαγάγετε. Δείτε το στιγμιότυπο οθόνης:
doc εισαγάγετε αρχεία κειμένου από ένα φάκελο 4

3. κλικ Ανοικτό > Okκαι το αρχείο καθορισμού κειμένου έχει εισαχθεί στη θέση του δρομέα, δείτε το στιγμιότυπο οθόνης:
doc εισαγάγετε αρχεία κειμένου από ένα φάκελο 5


Τα καλύτερα εργαλεία παραγωγικότητας του Office

Το Kutools για Excel λύνει τα περισσότερα από τα προβλήματά σας και αυξάνει την παραγωγικότητά σας κατά 80%

  • Επαναχρησιμοποίηση: Εισαγάγετε γρήγορα σύνθετοι τύποι, γραφήματα και οτιδήποτε έχετε χρησιμοποιήσει στο παρελθόν. Κρυπτογράφηση κυττάρων με κωδικό πρόσβασης Δημιουργία λίστας αλληλογραφίας και στείλτε email ...
  • Super Formula Bar (επεξεργαστείτε εύκολα πολλές γραμμές κειμένου και τύπου). Διάταξη ανάγνωσης (εύκολη ανάγνωση και επεξεργασία μεγάλου αριθμού κελιών). Επικόλληση σε φιλτραρισμένο εύρος...
  • Συγχώνευση κελιών / σειρών / στηλών χωρίς απώλεια δεδομένων · Περιεχόμενο διαχωρισμού κελιών Συνδυάστε διπλές σειρές / στήλες... Αποτροπή διπλών κυττάρων; Συγκρίνετε τα εύρη...
  • Επιλέξτε Διπλότυπο ή Μοναδικό Σειρές; Επιλέξτε Κενές σειρές (όλα τα κελιά είναι κενά). Σούπερ εύρεση και ασαφής εύρεση σε πολλά βιβλία εργασίας. Τυχαία επιλογή ...
  • Ακριβές αντίγραφο Πολλαπλά κελιά χωρίς αλλαγή της αναφοράς τύπου. Αυτόματη δημιουργία αναφορών σε πολλαπλά φύλλα? Εισαγωγή κουκκίδων, Πλαίσια ελέγχου και άλλα ...
  • Εξαγωγή κειμένου, Προσθήκη κειμένου, Κατάργηση κατά θέση, Αφαιρέστε το διάστημα; Δημιουργία και εκτύπωση υποσύνολων σελιδοποίησης. Μετατροπή περιεχομένου και σχολίων μεταξύ κελιών...
  • Σούπερ φίλτρο (αποθηκεύστε και εφαρμόστε σχήματα φίλτρων σε άλλα φύλλα). Προηγμένη ταξινόμηση ανά μήνα / εβδομάδα / ημέρα, συχνότητα και άλλα. Ειδικό φίλτρο με έντονη, πλάγια ...
  • Συνδυάστε βιβλία εργασίας και φύλλα εργασίας; Συγχώνευση πινάκων βάσει βασικών στηλών. Διαχωρίστε τα δεδομένα σε πολλά φύλλα; Μαζική μετατροπή xls, xlsx και PDF...
  • Περισσότερα από 300 ισχυρά χαρακτηριστικά. Υποστηρίζει Office / Excel 2007-2021 και 365. Υποστηρίζει όλες τις γλώσσες. Εύκολη ανάπτυξη στην επιχείρηση ή τον οργανισμό σας. Πλήρεις δυνατότητες δωρεάν δοκιμής 30 ημερών. Εγγύηση επιστροφής χρημάτων 60 ημερών.
kte καρτέλα 201905

Το Office Tab φέρνει τη διεπαφή με καρτέλες στο Office και κάνει την εργασία σας πολύ πιο εύκολη

  • Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
  • Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
  • Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
κάτω μέρος γραφείου
Σχόλια (46)
Βαθμολογήθηκε το 4 από το 5 · αξιολογήσεις 1
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Sub Test ()
'ΕνημέρωσηExtendoffice6 / 7 / 2016
Dim xWb ως βιβλίο εργασίας
Dim xToBook ως βιβλίο εργασίας
Dim xStrPath ως συμβολοσειρά
Dim xFileDialog ως FileDialog
Dim xFile ως συμβολοσειρά
Dim xFiles ως νέα συλλογή
Dim I As Long
Ορισμός 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
Αν xFiles.Count > 0 Τότε
Για I = 1 To xFiles.Count
Ορισμός xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Αντιγραφή μετά:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Συνέχιση Επόμενη
ActiveSheet.Name = xWb.Name
Στο σφάλμα GoTo 0
xWb.Κλείσιμο False
Επόμενο
End If
Sub End

αυτός ο κωδικός βοηθάει αλλά θέλω

καρτέλα, άνω τελεία, κενό αληθινό πώς να το κάνω αυτό παρακαλώ βοηθήστε με
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Θέλετε να διατηρήσετε το διάστημα (οριοθέτες) μετά τη μετατροπή των αρχείων κειμένου σε φύλλα;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
αυτό είναι και το πρόβλημά μου, αυτός ο κωδικός είναι αληθινός. αλλά μετά τη μετατροπή αρχείων κειμένου σε excel, δεν διατηρεί τους οριοθέτες.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Θα μπορούσατε να ανεβάσετε το αρχείο κειμένου και το αποτέλεσμα που θέλετε για μένα;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Εχω το ίδιο πρόβλημα. Τα αρχεία txt είναι όλα σε ξεχωριστά φύλλα και ο κώδικας αγνοεί το διάστημα μεταξύ των δύο στηλών
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας, 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
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
πώς να κάνω εάν το αρχείο Txt μου περιέχει οριοθετημένο με κόμμα;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Μπορείτε να χρησιμοποιήσετε το Fuctuon Find and Replace για να αντικαταστήσετε πρώτα το κόμμα με κενό και να εφαρμόσετε μία από τις παραπάνω μεθόδους για να το μετατρέψετε σε αρχείο Excel.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Δεν υπάρχει τρόπος να αλλάξει αυτό στον κώδικα; Θα έπρεπε να το κάνω αυτό με 130 αρχεία
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ιδια ερώτηση
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Για όσους εξακολουθούν να χρειάζονται βοήθεια με αυτό, αντικαταστήστε το xArr = Split(xRg.Text, " ") με το xArr = Split(xRg.Text, ",").
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Όταν εκτελώ τη λειτουργική μονάδα όπως δίνεται, προσθέτει κάθε αρχείο .txt ως νέο φύλλο, όχι ως νέα γραμμή στο υπάρχον φύλλο. Υπάρχει τρόπος να επιτευχθεί αυτό ως έξοδος αντί για νέα φύλλα για κάθε αρχείο .txt;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Εννοείτε να συνδυάσετε όλο το αρχείο κειμένου σε ένα φύλλο;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ναι αυτό θέλω και εγώ.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, 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 μαζικά, η επιδιόρθωση που χρειάζομαι είναι επίσης αυτό που αναζητούν ο Joyce και ο Davinder.
Είναι να εξαγάγετε τα αρχεία .txt και να τα επικολλήσετε όλα το ένα κάτω από το άλλο σε μια συγκεκριμένη στήλη, ας πούμε στήλη 'N'.

Επίσης, πρέπει να ξέρετε εάν θα είναι δυνατό να προσθέσετε μια συνθήκη "if" για τα αρχεία .txt που εισάγονται να είναι ως εξής.
εάν τα αρχεία .txt ξεκινούν με το γράμμα "A", τότε θα επικολληθούν στο "φύλλο 1" ξεκινώντας με το κελί "N2"
και αν τα αρχεία .txt ξεκινούν με το γράμμα "B", τότε επικολλήστε στο "Φύλλο 2" ξεκινώντας με το κελί "N2"
else MsgBox να είναι "Μη αναγνωρισμένος σκοπός αρχείου .txt".

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

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

*πρέπει να εισαγάγετε ένα υπό όρους εάν για αρχεία 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
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Συγγνώμη, τα χέρια μου είναι δεμένα
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, ο κώδικας μου εκτελείται αλλά εισάγει μόνο το πρώτο αρχείο. Λέει ότι υπήρξε σφάλμα μεθόδου για την αντιγραφή. Το πρόγραμμα εντοπισμού σφαλμάτων επισημαίνει την ακόλουθη γραμμή κώδικα. Καμιά ιδέα?


xWb.Worksheets(1).Αντιγραφή μετά:=xToBook.Sheets(xToBook.Sheets.Count)
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Έχω το ίδιο πρόβλημα, υπάρχουν λύσεις;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Καίτη,
Γνωρίζω ότι το σχόλιό σας είναι αρκετά παλιό, αλλά αντιμετώπισα το ίδιο πρόβλημα και το διόρθωσα ως εξής: Η λειτουργική μονάδα πρέπει να εισαχθεί σε έναν υποφάκελο του ενεργού έργου .xlsx. Έκανα το λάθος να αντιγράψω τον κώδικα σε έναν υποφάκελο του PERSONAL.XLSB μου όπου συνήθως αποθηκεύω τις μακροεντολές μου και αυτό συμβαίνει με τις άλλες μακροεντολές μου, αλλά όχι με αυτήν.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Πώς θα διαγράφατε τα φύλλα στον κώδικα vba εάν δεν θέλετε διπλότυπα κατά την επανεκτέλεση της λειτουργικής μονάδας;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Συγγνώμη, Σκληρός, απλά να είστε προσεκτικοί για να αποφύγετε την επανειλημμένη εισαγωγή.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
γεια, θέλω να αποτρέψω την αφαίρεση των προηγούμενων μηδενικών στο excel.

Δοκίμασα τον παρακάτω κώδικα αλλά δεν λειτουργεί


Sub Test ()
Dim xWb ως βιβλίο εργασίας
Dim xToBook ως βιβλίο εργασίας
Dim xStrPath ως συμβολοσειρά
Dim xFileDialog ως FileDialog
Dim xFile ως συμβολοσειρά
Dim xFiles ως νέα συλλογή
Dim I As Long
Dim J όσο πολύ καιρό
Ορισμός xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Επιλογή φακέλου"
Αν 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
Αν xFiles.Count > 0 Τότε
Για I = 1 To xFiles.Count
Ορισμός xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" 'Αυτό είναι για να δημιουργήσετε το Excel σε μορφή κειμένου πριν επικολλήσετε τα δεδομένα του αρχείου κειμένου
xWb.Worksheets(1).Copy After:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Συνέχιση Επόμενη
ActiveSheet.Name = xWb.Name
Στο σφάλμα GoTo 0
xWb.Κλείσιμο False
Επόμενο
End If
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Pooja, μπορείτε να δοκιμάσετε τη λειτουργία Remove Leading Zeros του Kutools για Excel για να αφαιρέσετε όλα τα κύρια μηδενικά από την επιλογή μετά την εισαγωγή.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
αλλά δεν θέλω να αφαιρέσω. Θέλω να αποτρέψω την αφαίρεση των προηγούμενων μηδενικών.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Εάν θέλετε να διατηρήσετε τα μηδενικά που προηγούνται, μπορείτε να τα μορφοποιήσετε ως μορφή κειμένου ανά Μορφή κελιού.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας, πώς μπορείτε να τροποποιήσετε αυτόν τον κώδικα για να εισάγετε αρχεία *.txt με τη σειρά: 1,2,3,4,5,6,7,8,9,10,11, κ.λπ. Επί του παρόντος, ο κώδικας εισάγει αρχεία ως εξής:1,10,11,12,13,14,15,16,17,18,19,2,20,21, XNUMX κ.λπ. Ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
υπάρχει πιθανότητα να ληφθούν ονόματα φύλλων μόνο ορισμένων τμημάτων από τα ονόματα αρχείων txt;

σύμφωνα με τον παραπάνω κωδικό έχει λάβει ολόκληρο το όνομα του φύλλου.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
ευχαριστώ πολύ για τη δουλειά στο office 2007 excel
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, ο κώδικας μου εκτελείται αλλά εισάγει μόνο το πρώτο αρχείο. Λέει ότι υπήρξε σφάλμα μεθόδου για την αντιγραφή. Το πρόγραμμα εντοπισμού σφαλμάτων επισημαίνει την ακόλουθη γραμμή κώδικα. Καμιά ιδέα?


xWb.Worksheets(1).Αντιγραφή μετά:=xToBook.Sheets(xToBook.Sheets.Count)
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Martinho,
Είχα το ίδιο πρόβλημα και το έλυσα αλλάζοντας αυτήν τη γραμμή:
Ορισμός xToBook = This Workbook
προς την
Ορίστε xToBook = ActiveWorkbook
Ίσως αυτό βοηθάει.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
0

χρειάζομαι τη βοήθειά σας δεν έχω ιδέα vba excel θέλω να εισαγάγω πολλαπλά αρχεία κειμένου όπως το 13000. το όνομα αρχείου κειμένου ίδιο με το κελί για παράδειγμα (c1=112 άρα το όνομα αρχείου κειμένου είναι επίσης 112) σημαίνει ότι το αρχείο κειμένου 112 είναι εισάγετε το c112.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
χρειάζομαι τη βοήθειά σας δεν έχω ιδέα vba excel θέλω να εισαγάγω πολλαπλά αρχεία κειμένου όπως το 13000. το όνομα αρχείου κειμένου ίδιο με το κελί για παράδειγμα (c1=112 άρα το όνομα αρχείου κειμένου είναι επίσης 112) σημαίνει ότι το αρχείο κειμένου 112 είναι εισάγετε το c112.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ο κώδικας λειτουργεί, αλλά εισάγει κάθε αρχείο κειμένου σε μια νέα καρτέλα στο βιβλίο εργασίας. Έχετε ιδέα πού στον κώδικα θα μπορούσε να αλλάξει αυτό για να εισαγάγετε το νέο αρχείο κειμένου στο ίδιο φύλλο εργασίας κάτω από τα δεδομένα από το τελευταίο αρχείο κειμένου;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Στον παρακάτω κώδικα, αν θέλω να καθορίσω το φάκελο αντί να επιλέγω τη διαδρομή κάθε φορά που εισάγω ένα αρχείο κειμένου, τι τροποποίηση πρέπει να κάνω

ΚΩΔΙΚΟΣ VBA:

Sub ImportCSVsWithReference()
«Ενημέρωση με KutoolsforExcel20151214
Dim xSht ως φύλλο εργασίας
Dim xWb ως βιβλίο εργασίας
Dim xStrPath ως συμβολοσειρά
Dim xFileDialog ως FileDialog
Dim xFile ως συμβολοσειρά
Σφάλμα Μετάβαση στο ErrHandler
Ορισμός xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Επιλέξτε έναν φάκελο [Kutools for Excel]"
Αν xFileDialog.Show = -1 Τότε
xStrPath = xFileDialog.SelectedItems(1)
End If
Αν xStrPath = "" Τότε βγείτε από το Sub
Ορίστε xSht = ThisWorkbook.ActiveSheet
Αν MsgBox("Εκκαθάριση του υπάρχοντος φύλλου πριν από την εισαγωγή;", vbYesNo, "Kutools for Excel") = vbYes Τότε xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.txt")
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
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, δοκιμάστε τον παρακάτω κώδικα
Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    xStrPath = "C:\Users\AddinsVM001\Desktop\test" 'Here is the parth you can modify
    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
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

"C:\Users\AddinsVM001\Desktop\test" είναι η διαδρομή φακέλου από την οποία μπορείτε να εισαγάγετε αρχείο κειμένου, αλλάξτε το όπως θέλετε.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας, ευχαριστώ για τον πολύτιμο κώδικα VBA σας.
Ωστόσο, χρειάζομαι έναν κωδικό για πολλά αρχεία txt σε «ένα μόνο φύλλο στο φύλλο εργασίας, όχι ένα μεμονωμένο φύλλο για κάθε αρχείο txt».
Τι πρέπει να επεξεργαστώ τον κωδικό σας για τον σκοπό μου;

Ευχαριστώ,
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, δοκιμάστε τον παρακάτω κώδικα
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
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό λειτουργεί καλά. Αλλά όταν εισάγει μετονομάζει φύλλα με name.txt πώς να το κάνουμε να διατηρεί μόνο το όνομα χωρίς να προσθέτει επέκταση .txt στο φύλλο;
Βαθμολογήθηκε το 3.5 από το 5
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ok nvm βρήκε απάντηση με τη βοήθεια της Google.
αντικαταστήστε τη γραμμή:
ActiveSheet.Name = xWb.Name
με:
ActiveSheet.Name = Left(xWb.Name,Len(xWb.Name)-4)
θα αφαιρούσε τα τελευταία 4 γράμματα από το όνομα του φύλλου. Δίνοντάς μου ουσιαστικά αυτό που χρειαζόμουν. όνομα χωρίς .txt
Εβίβα
Βαθμολογήθηκε το 4 από το 5
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ο παρακάτω κώδικας μπορεί να χωρίσει τα δεδομένα σε στήλες με βάση το διάστημα ή την καρτέλα κατά την εισαγωγή αρχείου κειμένου σε φύλλα. Αλλά δεν θέλω ξεχωριστή καρτέλα για κάθε αρχείο txt, θα τα ήθελα όλα κάτω από ένα φύλλο. Οι πληροφορίες έχουν την ίδια μορφή για κάθε αρχείο. . Τι μπορεί να τροποποιηθεί για να επιτρέπεται σε αυτό να είναι ένα φύλλο αντί κάθε αρχείο που εισάγεται να είναι μια νέα καρτέλα, οποιαδήποτε και κάθε βοήθεια θα εκτιμούσαμε

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
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, 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


Δεν υπάρχουν σχόλια δημοσιεύτηκε ακόμα
Αφήστε τα σχόλιά σας
Δημοσίευση ως επισκέπτης
×
Αξιολογήστε αυτήν την ανάρτηση:
0   Χαρακτήρες
Προτεινόμενες τοποθεσίες

Ακολουθησε μας

Πνευματικά δικαιώματα © 2009 - www.extendoffice.com. | Ολα τα δικαιώματα διατηρούνται. Τροφοδοτείται από ExtendOffice. | Sitemap
Το Microsoft και το λογότυπο του Office είναι εμπορικά σήματα ή σήματα κατατεθέντα της Microsoft Corporation στις Ηνωμένες Πολιτείες ή / και σε άλλες χώρες.
Προστατεύεται από το Sectigo SSL