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

Cum se importă mai multe fișiere text dintr-un folder într-o singură foaie de lucru?

De exemplu, aici aveți un folder cu mai multe fișiere text, ceea ce doriți să faceți este să importați aceste fișiere text într-o singură foaie de lucru, așa cum se arată în imaginea de mai jos. În loc să copiați fișierele text unul câte unul, există trucuri pentru a importa rapid fișierele text dintr-un folder într-o singură foaie?

Importați mai multe fișiere text dintr-un folder într-o singură foaie cu VBA

Importați fișierul text în celula activă cu Kutools pentru Excel idee bună3


Iată un cod VBA care vă poate ajuta să importați toate fișierele text dintr-un folder specific într-o foaie nouă.

1. Activați un registru de lucru pe care doriți să îl importați fișiere text și apăsați Alt + F11 taste pentru activare Microsoft Visual Basic pentru aplicații fereastră.

2. clic Insera > Module, copiați și lipiți sub codul VBA în Module fereastră.

VBA: Importați mai multe fișiere text dintr-un dosar într-o coală

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. presa F5 pentru a afișa un dialog și selectați un folder care conține fișiere text pe care doriți să le importați. Vedeți captura de ecran:
doc import fișiere text dintr-un folder 1

4. clic OK. Apoi fișierele text au fost importate separat în registrul de lucru activ ca foaie nouă.
doc import fișiere text dintr-un folder 2


Dacă doriți să importați un fișier text într-o anumită celulă sau interval, puteți aplica Kutools pentru Excel'S Inserați fișierul la cursor utilitate.

Kutools pentru Excel, cu mai mult de 300 funcții la îndemână, vă face munca mai ușoară. 

După instalare gratuită Kutools pentru Excel, faceți următoarele:

1. Selectați o celulă pe care doriți să o importați fișierul text și faceți clic pe Kutools Plus > Import Export > Inserați fișierul la cursor. Vedeți captura de ecran:
doc import fișiere text dintr-un folder 3

2. Apoi apare un dialog, faceți clic pe Naviga pentru a afișa Selectați un fișier pentru a fi inserat în caseta de dialog a poziției cursorului, selectați apoi Fișiere text din lista derulantă, apoi alegeți fișierul text pe care doriți să îl importați. Vedeți captura de ecran:
doc import fișiere text dintr-un folder 4

3. clic Înscrieri în > Ok, iar fișierul text specificat a fost inserat în poziția cursorului, consultați captura de ecran:
doc import fișiere text dintr-un folder 5


Cele mai bune instrumente de productivitate Office

Kutools pentru Excel vă rezolvă majoritatea problemelor și vă crește productivitatea cu 80%

  • reutilizarea: Introduceți rapid formule complexe, diagrame și orice ai folosit anterior; Criptați celulele cu parola; Creați o listă de corespondență și trimiteți e-mailuri ...
  • Super Formula Bar (editați cu ușurință mai multe linii de text și formulă); Layout de citire (citiți și editați cu ușurință un număr mare de celule); Lipiți la interval filtrat...
  • Merge celule / rânduri / coloane fără a pierde date; Conținut de celule divizate; Combinați rânduri / coloane duplicate... Prevenirea celulelor duplicate; Comparați gamele...
  • Selectați Duplicat sau Unic Rânduri; Selectați Rânduri goale (toate celulele sunt goale); Super Find și Fuzzy Find în multe cărți de lucru; Selectare aleatorie ...
  • Copie exactă Mai multe celule fără modificarea referinței formulelor; Creați automat referințe la foi multiple; Introduceți gloanțe, Casete de selectare și multe altele ...
  • Extrageți textul, Adăugați text, eliminați după poziție, Eliminați spațiul; Creați și imprimați subtotaluri de paginare; Convertiți conținutul dintre celule și comentarii...
  • Super Filtru (salvați și aplicați scheme de filtrare altor foi); Sortare avansată după lună / săptămână / zi, frecvență și multe altele; Filtru special cu bold, italic ...
  • Combinați cărți de lucru și foi de lucru; Merge Tables pe baza coloanelor cheie; Împărțiți datele în mai multe foi; Conversia în loturi xls, xlsx și PDF...
  • Peste 300 de funcții puternice. Suportă Office / Excel 2007-2021 și 365. Acceptă toate limbile. Implementare ușoară în întreprinderea sau organizația dvs. Funcții complete Probă gratuită de 30 de zile. Garanție de returnare a banilor de 60 de zile.
fila kte 201905

Fila Office aduce interfața cu file în Office și vă face munca mult mai ușoară

  • Activați editarea și citirea cu file în Word, Excel, PowerPoint, Publisher, Access, Visio și Project.
  • Deschideți și creați mai multe documente în filele noi ale aceleiași ferestre, mai degrabă decât în ​​ferestrele noi.
  • Vă crește productivitatea cu 50% și reduce sute de clicuri de mouse pentru dvs. în fiecare zi!
fundul officetab
Comentarii (46)
Evaluat 4 din 5 · evaluări 1
Acest comentariu a fost redus la minimum de moderatorul de pe site
Sub Test ()
'Actualizare deExtendoffice6/7/2016
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim I As Long
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & „*.txt”)
Dacă xFile = "" Atunci
MsgBox „Nu s-au găsit fișiere”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Faceți în timp ce xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Buclă
Setați xToBook = ThisWorkbook
Dacă xFiles.Count > 0 Atunci
Pentru I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Foaie de lucru(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
La data de eroare CV următoare
ActiveSheet.Name = xWb.Name
La eroare GoTo 0
xWb.Închide False
Pagina Următoare →
Final, dacă
End Sub

acest cod este de ajutor, dar vreau

tab, punct și virgulă, spațiu adevărat cum se face, vă rog să mă ajutați
Acest comentariu a fost redus la minimum de moderatorul de pe site
Doriți să păstrați spațiul (delimitatorii) după convertirea fișierelor text în foi?
Acest comentariu a fost redus la minimum de moderatorul de pe site
asta este si problema mea, acest cod este adevarat. dar după convertirea fișierelor text în excel, nu păstrează delimitatorii.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Ați putea încărca fișierul text și rezultatul pe care îl doriți pentru mine?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Am aceeasi problema. Fișierele txt sunt toate în foi separate, iar codul ignoră spațiul dintre cele două coloane
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună ziua, Des și PB Rama Murty, codul de mai jos poate împărți datele în coloane pe baza spațiului sau a filei în timpul importării fișierului text în foi. Puteți încerca.

Sub ImportTextToExcel()
'Actualizare deExtendoffice20180911
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ca șir
Dim xRg As Range
Dim xArr
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & „*.txt”)
Dacă xFile = "" Atunci
MsgBox „Nu s-au găsit fișiere”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Faceți în timp ce xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Buclă
Setați xToBook = ThisWorkbook
La data de eroare CV următoare
Application.ScreenUpdating = Fals
Dacă xFiles.Count > 0 Atunci

Pentru I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Foaie de lucru(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Închide False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Pentru xFNum = 1 Pentru xIntRow
Set xRg = ActiveSheet.Range(„A” și xFNum)
xArr = Split(xRg.Text, " ")
Dacă UBound(xArr) > 0, atunci
Pentru xFArr = 0 To UBound(xArr)
Dacă xArr(xFArr) <> "" Atunci
xRg.Value = xArr(xFArr)
Set xRg = xRg.Offset(ColumnOffset:=1)
Final, dacă
Pagina Următoare →
Final, dacă
Pagina Următoare →
Pagina Următoare →
Final, dacă
Application.ScreenUpdating = Adevărat
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Ce modificări sunt necesare dacă doriți să împărțiți datele în coloane bazate pe virgulă
Acest comentariu a fost redus la minimum de moderatorul de pe site
Ce modificări trebuie făcute dacă am nevoie de toate datele în coloane bazate pe virgulă?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Am folosit asta și funcționează, dar aș dori ca totul să fie salvat pe o singură foaie, deoarece fiecare foaie este aceeași informație, sunt doar fișiere jurnal din fiecare zi.
deci trebuie să combin
toate articolele din folder într-o singură foaie
Sub ImportCSVsWithReference()
„Actualizare de KutoolsforExcel20151214
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ca șir
Dim xRg As Range
Dim xArr
La eroare GoTo ErrHandler
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
Set xSht = ThisWorkbook.ActiveSheet
Dacă MsgBox(„Ștergeți foaia existentă înainte de a importa?”, vbYesNo, „Kutools for Excel”) = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = Fals
xFile = Dir(xStrPath & "\" & "*.log")
Faceți în timp ce xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range(„A” și Rows.Count).End(xlUp).Offset(1)
xWb.Închide False
xFile = Dir
Buclă
Application.ScreenUpdating = Adevărat
Ieșiți din Sub
ErrHandler:
MsgBox „fără fișiere txt”, , „Kutools pentru Excel”
End Sub

și acesta care ues spații pentru a dd la fiecare coloană

Sub ImportTextToExcel()
'Actualizare deExtendoffice20180911
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ca șir
Dim xRg As Range
Dim xArr
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & „*.txt”)
Dacă xFile = "" Atunci
MsgBox „Nu s-au găsit fișiere”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Faceți în timp ce xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Buclă
Setați xToBook = ThisWorkbook
La data de eroare CV următoare
Application.ScreenUpdating = Fals
Dacă xFiles.Count > 0 Atunci

Pentru I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Foaie de lucru(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Închide False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Pentru xFNum = 1 Pentru xIntRow
Set xRg = ActiveSheet.Range(„A” și xFNum)
xArr = Split(xRg.Text, " ")
Dacă UBound(xArr) > 0, atunci
Pentru xFArr = 0 To UBound(xArr)
Dacă xArr(xFArr) <> "" Atunci
xRg.Value = xArr(xFArr)
Set xRg = xRg.Offset(ColumnOffset:=1)
Final, dacă
Pagina Următoare →
Final, dacă
Pagina Următoare →
Pagina Următoare →
Final, dacă
Application.ScreenUpdating = Adevărat
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
cum să fac dacă fișierul meu Txt conține delimitat folosind virgulă?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Puteți utiliza funcția Găsiți și înlocuiți pentru a înlocui mai întâi virgula cu spațiu și aplicați una dintre metodele de mai sus pentru a o converti în fișier Excel.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Nu există o modalitate de a schimba acest lucru în cod? Ar trebui să fac asta cu 130 de fișiere
Acest comentariu a fost redus la minimum de moderatorul de pe site
Aceeasi intrebare
Acest comentariu a fost redus la minimum de moderatorul de pe site
Pentru cei care mai au nevoie de ajutor cu aceasta, înlocuiți xArr = Split(xRg.Text, " ") cu xArr = Split(xRg.Text, ",").
Acest comentariu a fost redus la minimum de moderatorul de pe site
Când rulez modulul așa cum este dat, acesta adaugă fiecare fișier .txt ca o foaie nouă, nu ca o linie nouă la foaia existentă. Există o modalitate de a realiza asta ca rezultat în loc de noi foi pentru fiecare fișier .txt?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Vrei să spui să combinați toate fișierele text într-o singură foaie?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Da asta vreau si eu.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, Davidder, poți încerca codul vba de mai jos.
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
Acest comentariu a fost redus la minimum de moderatorul de pe site
Codul este foarte util, este singurul cod pe care l-am găsit care primește fișiere txt în vrac. Remedierea de care am nevoie este și ceea ce urmăresc Joyce și Davinder.
Este să extrageți fișierele .txt și să le lipiți pe toate unul sub celălalt într-o coloană specifică, să spunem coloana „N”.

De asemenea, trebuie să știți dacă va fi posibil să adăugați o „condiție dacă” pentru ca fișierele .txt importate să fie după cum urmează.
dacă fișierele .txt încep cu litera „A”, atunci vor fi lipite pe „foaia 1” începând cu celula „N2”
și dacă fișierele .txt încep cu litera „B”, apoi lipiți pe „Foaie 2” începând cu celula „N2”
altfel MsgBox să fie „Scopul fișierului .txt nerecunoscut”.

vă mulțumesc în avans
Acest comentariu a fost redus la minimum de moderatorul de pe site
Acest cod a funcționat pentru mine, dar totuși, trebuie să schimb ceva în el.

*Vreau să se lipească pe aceeași foaie fără a deschide o foaie nouă, apoi o copiez deoarece durează mai mult timp.

*trebuie să inserați o condițională dacă pentru fișierele txt importate să fie lipite pe foaia 1 dacă începe cu litera A și importate în foaia 2 dacă începe cu litera B


Sub testcopy3()
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim i As Long
Dim LastRow As Long
Dim Rng ca rază de acțiune
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & „*.txt”)
Dacă xFile = "" Atunci
MsgBox „Nu s-au găsit fișiere”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Faceți în timp ce xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Buclă
Interval("N2").Selectați
Setați xToBook = ThisWorkbook
Dacă xFiles.Count > 0 Atunci
Pentru i = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Activare
„Selectarea și copierea datelor txt
Interval(Selectie, Selection.End(xlDown)).Select
Selectare.Copiere
xToBook.Activate
ActiveSheet.Paste
Selection.End(xlDown).Offset(1).Select
La data de eroare CV următoare
La eroare GoTo 0
xWb.Închide False
Pagina Următoare →
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Îmi pare rău, am mâinile legate
Acest comentariu a fost redus la minimum de moderatorul de pe site
Salut, codul meu rulează, dar importă doar primul fișier. Spune că a apărut o eroare de metodă pentru copiere. Depanatorul evidențiază următoarea linie de cod. Vreo idee?


xWb.Foaie de lucru(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
Acest comentariu a fost redus la minimum de moderatorul de pe site
Am aceeași problemă, am găsit soluții?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Hei, katie,
Știu că comentariul tău este destul de vechi, dar m-am confruntat cu aceeași problemă și am rezolvat-o astfel: modulul trebuie să fie inserat într-un subfolder al proiectului activ .xlsx. Am făcut greșeala de a copia codul într-un subfolder al meu PERSONAL.XLSB unde de obicei îmi stochez macrocomenzile și se întâmplă cu celelalte macrocomenzi ale mele, dar nu cu aceasta.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Cum ați șterge foile din codul vba dacă nu doriți duplicate la re-executarea modulului?
Acest comentariu a fost redus la minimum de moderatorul de pe site
Ne pare rău, Harsh, ai grijă să nu faci importuri repetate.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Salut, vreau să împiedic eliminarea zero-urilor anterioare din Excel.

Am încercat codul de mai jos, dar nu funcționează


Sub Test ()
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim I As Long
Dim j As Long
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & „*.txt”)
Dacă xFile = "" Atunci
MsgBox „Nu s-au găsit fișiere”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Faceți în timp ce xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Buclă
Setați xToBook = ThisWorkbook
Dacă xFiles.Count > 0 Atunci
Pentru I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" 'Acesta este pentru a face Excel în format text înainte de a lipi datele fișierului text
xWb.Foaie de lucru(1).Copy After:=xToBook.Sheets(xToBook.Sheets.Count)
La data de eroare CV următoare
ActiveSheet.Name = xWb.Name
La eroare GoTo 0
xWb.Închide False
Pagina Următoare →
Final, dacă
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Pooja, puteți încerca funcția Eliminați zerourile de început din Kutools pentru Excel pentru a elimina toate zerourile de început din selecție după importare.
Acest comentariu a fost redus la minimum de moderatorul de pe site
dar nu vreau să elimin. Vreau să împiedic eliminarea zero-urilor anterioare.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Dacă doriți să păstrați zerourile inițiale, le puteți formata ca format text în format de celulă.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună ziua, cum modificați acest cod pentru a insera fișiere *.txt în ordine: 1,2,3,4,5,6,7,8,9,10,11 etc. În prezent, codul inserează fișierele după cum urmează:1,10,11,12,13,14,15,16,17,18,19,2,20,21, XNUMX etc. Mulțumesc!
Acest comentariu a fost redus la minimum de moderatorul de pe site
Există vreo șansă de a lua nume de foi doar o anumită parte din numele fișierelor txt?

conform codului de mai sus, întregul nume al foii a fost luat.
Acest comentariu a fost redus la minimum de moderatorul de pe site
mulțumesc mult am făcut treaba pe Office 2007 Excel
Acest comentariu a fost redus la minimum de moderatorul de pe site
Salut, codul meu rulează, dar importă doar primul fișier. Spune că a apărut o eroare de metodă pentru copiere. Depanatorul evidențiază următoarea linie de cod. Vreo idee?


xWb.Foaie de lucru(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
Acest comentariu a fost redus la minimum de moderatorul de pe site
Salut Martinho,
Am avut aceeași problemă și am rezolvat-o schimbând această linie:
Setați xToBook = ThisWorkbook
la
Setați xToBook = ActiveWorkbook
Poate că asta ajută.
Acest comentariu a fost redus la minimum de moderatorul de pe site
0

Am nevoie de ajutorul dvs. Nu am nicio idee Vba Excel Vreau să import mai multe fișiere text, cum ar fi 13000. numele fișierului text la fel ca celula, de exemplu (c1=112, deci numele fișierului text este, de asemenea, 112) înseamnă că fișierul text 112 este importați c112.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Am nevoie de ajutorul dvs. Nu am nicio idee Vba Excel Vreau să import mai multe fișiere text, cum ar fi 13000. numele fișierului text la fel ca celula, de exemplu (c1=112, deci numele fișierului text este, de asemenea, 112) înseamnă că fișierul text 112 este importați c112.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Codul funcționează, dar importă fiecare fișier text într-o filă nouă din registrul de lucru. Aveți idee unde în cod ar putea fi schimbat pentru a importa noul fișier text pe aceeași foaie de lucru sub datele din ultimul fișier text?
Acest comentariu a fost redus la minimum de moderatorul de pe site
În codul de mai jos, dacă vreau să specific folderul în loc să selectez calea de fiecare dată când import un fișier text, ce modificări trebuie să facă

COD VBA:

Sub ImportCSVsWithReference()
„Actualizare de KutoolsforExcel20151214
Dim xSht ca foaie de lucru
Dim xWb ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
La eroare GoTo ErrHandler
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Set xSht = ThisWorkbook.ActiveSheet
Dacă MsgBox(„Ștergeți foaia existentă înainte de a importa?”, vbYesNo, „Kutools for Excel”) = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = Fals
xFile = Dir(xStrPath & „\” & „*.txt”)
Faceți în timp ce xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range(„A” și Rows.Count).End(xlUp).Offset(1)
xWb.Închide False
xFile = Dir
Buclă
Application.ScreenUpdating = Adevărat
Ieșiți din Sub
ErrHandler:
MsgBox „fără fișiere txt”, , „Kutools pentru Excel”
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, vă rugăm să încercați codul de mai jos
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” este calea folderului din care puteți importa fișierul text, vă rugăm să o modificați după cum aveți nevoie.
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, mulțumesc pentru codul tău valoros VBA.
Cu toate acestea, am nevoie de un cod pentru mai multe fișiere txt într-o singură foaie în foaia de lucru, nu o foaie individuală pentru fiecare fișier txt.
Ce ar trebui să vă editez codul în scopul meu?

Multumesc,
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, vă rugăm să încercați codul de mai jos
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
Acest comentariu a fost redus la minimum de moderatorul de pe site
Acest lucru funcționează bine. Dar atunci când importă, redenumește foile cu name.txt cum să-l facă să păstreze numai numele fără a adăuga extensia .txt la foaie?
Evaluat 3.5 din 5
Acest comentariu a fost redus la minimum de moderatorul de pe site
Ok, nvm a găsit răspunsul cu ajutorul Google.
înlocuiți linia:
ActiveSheet.Name = xWb.Name
cu:
ActiveSheet.Name = Left(xWb.Name,Len(xWb.Name)-4)
ar elimina ultimele 4 litere din numele foii. Dându-mi efectiv ceea ce aveam nevoie. nume fără .txt
Noroc
Evaluat 4 din 5
Acest comentariu a fost redus la minimum de moderatorul de pe site
codul de mai jos poate împărți datele în coloane în funcție de spațiu sau tab în timp ce importă fișierul text în foi. Dar nu vreau o filă separată pentru fiecare fișier txt pe care le-aș dori pe toate sub o singură foaie. Informațiile au același format pentru fiecare fișier. . Ce poate fi modificat pentru a permite ca aceasta să fie o singură coală, în loc ca fiecare fișier importat să fie o filă nouă, orice ajutor ar fi apreciat

Sub ImportTextToExcel()
'Actualizare deExtendoffice20180911
Dim xWb ca registru de lucru
Dim xToBook ca registru de lucru
Dim xStrPath ca șir
Dim xFileDialog ca FileDialog
Dim xFile ca șir
Dim xFiles ca colecție nouă
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue ca șir
Dim xRg As Range
Dim xArr
Setați xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Fals
xFileDialog.Title = „Selectați un folder [Kutools pentru Excel]”
Dacă xFileDialog.Show = -1, atunci
xStrPath = xFileDialog.SelectedItems(1)
Final, dacă
Dacă xStrPath = "" Ieșiți din sub
Dacă Right(xStrPath, 1) <> "\" Atunci xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & „*.txt”)
Dacă xFile = "" Atunci
MsgBox „Nu s-au găsit fișiere”, vbInformation, „Kutools pentru Excel”
Ieșiți din Sub
Final, dacă
Faceți în timp ce xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Buclă
Setați xToBook = ThisWorkbook
La data de eroare CV următoare
Application.ScreenUpdating = Fals
Dacă xFiles.Count > 0 Atunci

Pentru I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Foaie de lucru(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Închide False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Pentru xFNum = 1 Pentru xIntRow
Set xRg = ActiveSheet.Range(„A” și xFNum)
xArr = Split(xRg.Text, " ")
Dacă UBound(xArr) > 0, atunci
Pentru xFArr = 0 To UBound(xArr)
Dacă xArr(xFArr) <> "" Atunci
xRg.Value = xArr(xFArr)
Set xRg = xRg.Offset(ColumnOffset:=1)
Final, dacă
Pagina Următoare →
Final, dacă
Pagina Următoare →
Pagina Următoare →
Final, dacă
Application.ScreenUpdating = Adevărat
End Sub
Acest comentariu a fost redus la minimum de moderatorul de pe site
Bună, Daniel, încearcă codul de mai jos, importă toate fișierele text într-o singură foaie numită Txt.
Observați că: dacă numele textului este același cu numele foii existente, este posibil ca fișierul text să nu fie importat.
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


Nu există comentarii postate aici încă
Lăsa comentarii
Postare ca invitat
×
Evaluează această postare:
0   Caractere
Locații sugerate

Urmărește-ne

Copyright © 2009 - www.extendoffice.com. | Toate drepturile rezervate. Cu sprijinul ExtendOffice. | Harta site-ului
Microsoft și sigla Office sunt mărci comerciale sau mărci comerciale înregistrate ale Microsoft Corporation în Statele Unite și / sau în alte țări.
Protejat de Sectigo SSL