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

Kako uvoziti več besedilnih datotek iz mape na en delovni list?

Tu imate na primer mapo z več besedilnimi datotekami, ki jih želite uvoziti v en delovni list, kot je prikazano spodaj. Namesto kopiranja besedilnih datotek eno za drugo, obstajajo kakšni triki za hiter uvoz besedilnih datotek iz ene mape na en list?

Uvozite več besedilnih datotek iz ene mape v en list z VBA

Uvozite besedilno datoteko v aktivno celico s programom Kutools za Excel dobra ideja3


Tukaj je koda VBA, ki vam lahko pomaga uvoziti vse besedilne datoteke iz ene določene mape na nov list.

1. Omogočite delovni zvezek, v katerega želite uvoziti besedilne datoteke, in pritisnite Alt + F11 tipke za omogočanje Microsoft Visual Basic za aplikacije okno.

2. klik Vstavi > Moduli, kopirajte in prilepite spodnjo kodo VBA v Moduli okno.

VBA: Uvozi več besedilnih datotek iz ene mape na en list

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. Pritisnite F5 , da prikažete pogovorno okno in izberite mapo, ki vsebuje besedilne datoteke, ki jih želite uvoziti. Oglejte si posnetek zaslona:
doc uvozi besedilne datoteke iz mape 1

4. klik OK. Nato so bile besedilne datoteke ločeno uvožene v aktivni delovni zvezek kot nov list.
doc uvozi besedilne datoteke iz mape 2


Če želite uvoziti eno besedilno datoteko v določeno celico ali obseg, se lahko prijavite Kutools za ExcelJe Vstavite datoteko v kazalec uporabnost.

Kutools za Excel, z več kot 300 priročne funkcije, vam olajša delo. 

po brezplačna namestitev Kutools za Excel, naredite spodaj:

1. Izberite celico, v katero želite uvoziti besedilno datoteko, in kliknite Kutools Plus > Uvozno-izvoznih > Vstavite datoteko v kazalec. Oglejte si posnetek zaslona:
doc uvozi besedilne datoteke iz mape 3

2. Nato se odpre pogovorno okno, kliknite Brskanje za prikaz Izberite datoteko za vstavitev v pogovorno okno položaja kurzorja celice, nato izberite Besedilne datoteke s spustnega seznama in nato izberite besedilno datoteko, ki jo želite uvoziti. Oglejte si posnetek zaslona:
doc uvozi besedilne datoteke iz mape 4

3. klik Odprto > Ok, in podana besedilna datoteka je bila vstavljena na položaj kazalca, glejte posnetek zaslona:
doc uvozi besedilne datoteke iz mape 5


Najboljša orodja za pisarniško produktivnost

Kutools za Excel rešuje večino vaših težav in poveča vašo produktivnost za 80%

  • Ponovna uporaba: Hitro vstavite zapletene formule, grafikoni in vse, kar ste že uporabljali; Šifriraj celice z geslom; Ustvari poštni seznam in pošiljanje e-pošte ...
  • Vrstica Super Formula (enostavno urejanje več vrstic besedila in formule); Bralna postavitev (enostavno branje in urejanje velikega števila celic); Prilepite v filtrirani obseg...
  • Združi celice / vrstice / stolpce brez izgube podatkov; Vsebina razdeljenih celic; Združi podvojene vrstice / stolpce... prepreči podvojene celice; Primerjaj obsege...
  • Izberite Duplicate ali Unique Vrstice; Izberite prazne vrstice (vse celice so prazne); Super Find in Fuzzy Find v mnogih delovnih zvezkih; Naključna izbira ...
  • Natančna kopija Več celic brez spreminjanja sklica formule; Samodejno ustvarjanje referenc na več listov; Vstavi oznake, Potrditvena polja in še več ...
  • Izvleček besedila, Dodaj besedilo, Odstrani po položaju, Odstrani presledek; Ustvari in natisni vmesne seštevke strani Pretvarjanje med vsebino celic in komentarji...
  • Super filter (shranite in uporabite sheme filtrov za druge liste); Napredno razvrščanje glede na mesec / teden / dan, pogostost in drugo; Poseben filter s krepko, ležeče ...
  • Združite delovne zvezke in delovne liste; Spoji tabele na podlagi ključnih stolpcev; Razdelite podatke na več listov; Paketna pretvorba xls, xlsx in PDF...
  • Več kot 300 zmogljivih funkcij. Podpira Office / Excel 2007-2021 in 365. Podpira vse jezike. Enostavna uvedba v vašem podjetju ali organizaciji. 30-dnevna brezplačna preizkusna različica vseh funkcij. 60-dnevna garancija vračila denarja.
zavihek kte 201905

Kartica Office prinaša vmesnik z zavihki v Office in poenostavi vaše delo

  • Omogočite urejanje in branje z zavihki v Wordu, Excelu, PowerPointu, Publisher, Access, Visio in Project.
  • Odprite in ustvarite več dokumentov v novih zavihkih istega okna in ne v novih oknih.
  • Poveča vašo produktivnost za 50%in vsak dan zmanjša na stotine klikov miške za vas!
dno pisarniške mize
Komentarji (46)
Ocenjeno 4 iz 5 · 1 ocene
Ta komentar je moderator na spletnem mestu minimiziral
Subtest()
'PosodobitevExtendoffice6 / 7 / 2016
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim I As Long
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Če je xFile = "" Potem
MsgBox "Ni najdenih datotek", vbInformation, "Kutools za Excel"
Exit Sub
Konec Če
Naredi, medtem ko xFile <> ""
xFiles.Dodaj xFile, xFile
xFile = Dir()
Zanka
Nastavite xToBook = Ta delovni zvezek
Če je xFiles.Count > 0 Potem
Za I = 1 Do xFiles.Count
Nastavi xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiraj po:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
Ob napaki Pojdi na 0
xWb.Zapri False
Naslednji
Konec Če
End Sub

ta koda mi pomaga, vendar hočem

tab, podpičje, presledek res, kako to narediti, prosim, pomagajte mi
Ta komentar je moderator na spletnem mestu minimiziral
Ali želite obdržati presledek (ločila) po pretvorbi besedilnih datotek v liste?
Ta komentar je moderator na spletnem mestu minimiziral
to je tudi moj problem, ta koda je resnična. vendar po pretvorbi besedilnih datotek v excel ne ohrani ločil.
Ta komentar je moderator na spletnem mestu minimiziral
Ali lahko naložite besedilno datoteko in rezultat, ki ga želite zame?
Ta komentar je moderator na spletnem mestu minimiziral
jaz imam enak problem. Datoteke txt so vse v ločenih listih in koda ne upošteva prostora med stolpcema
Ta komentar je moderator na spletnem mestu minimiziral
Pozdravljeni, Des in PB Rama Murty, spodnja koda lahko razdeli podatke v stolpce na podlagi presledka ali tabulatorja, medtem ko uvaža besedilno datoteko na liste. Lahko poskusite.

Sub ImportTextToExcel()
'PosodobitevExtendoffice20180911
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue kot niz
Dim xRg As Range
Dim xArr
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Če je xFile = "" Potem
MsgBox "Ni najdenih datotek", vbInformation, "Kutools za Excel"
Exit Sub
Konec Če
Naredi, medtem ko xFile <> ""
xFiles.Dodaj xFile, xFile
xFile = Dir()
Zanka
Nastavite xToBook = Ta delovni zvezek
On Error Resume Next
Application.ScreenUpdating = Napačno
Če je xFiles.Count > 0 Potem

Za I = 1 Do xFiles.Count
Nastavi xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiraj po:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Zapri False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Za xFNum = 1 do xIntRow
Nastavite xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Če je UBound(xArr) > 0 Potem
Za xFArr = 0 do UBound(xArr)
Če xArr(xFArr) <> "" Potem
xRg.Vrednost = xArr(xFArr)
Nastavi xRg = xRg.Offset(ColumnOffset:=1)
Konec Če
Naslednji
Konec Če
Naslednji
Naslednji
Konec Če
Application.ScreenUpdating = Res
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Katere spremembe so potrebne, če želite podatke razdeliti v stolpce na podlagi vejice
Ta komentar je moderator na spletnem mestu minimiziral
Kakšne spremembe je treba narediti, če potrebujem vse podatke v stolpce na podlagi vejice?
Ta komentar je moderator na spletnem mestu minimiziral
Uporabil sem to in deluje, vendar bi rad, da se vse shrani na en list, saj je na vsakem listu enaka informacija, to so le dnevniške datoteke za vsak dan.
zato moram združiti
vse elemente v mapi na en list
Sub ImportCSVsWithReference()
'Posodobi z Kutools forExcel20151214
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue kot niz
Dim xRg As Range
Dim xArr
Ob napaki Pojdi na ErrHandler
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
Nastavite xSht = ThisWorkbook.ActiveSheet
If MsgBox("Počisti obstoječi list pred uvozom?", vbYesNo, "Kutools for Excel") = vbYes Potem xSht.UsedRange.Clear
Application.ScreenUpdating = Napačno
xFile = Dir(xStrPath & "\" & "*.log")
Naredi, medtem ko xFile <> ""
Nastavi xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Zapri False
xDatoteka = Dir
Zanka
Application.ScreenUpdating = Res
Exit Sub
ErrHandler:
MsgBox "brez datotek txt", , "Kutools za Excel"
End Sub

in ta, ki uporablja presledke za dd v vsakem stolpcu

Sub ImportTextToExcel()
'PosodobitevExtendoffice20180911
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue kot niz
Dim xRg As Range
Dim xArr
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Če je xFile = "" Potem
MsgBox "Ni najdenih datotek", vbInformation, "Kutools za Excel"
Exit Sub
Konec Če
Naredi, medtem ko xFile <> ""
xFiles.Dodaj xFile, xFile
xFile = Dir()
Zanka
Nastavite xToBook = Ta delovni zvezek
On Error Resume Next
Application.ScreenUpdating = Napačno
Če je xFiles.Count > 0 Potem

Za I = 1 Do xFiles.Count
Nastavi xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiraj po:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Zapri False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Za xFNum = 1 do xIntRow
Nastavite xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Če je UBound(xArr) > 0 Potem
Za xFArr = 0 do UBound(xArr)
Če xArr(xFArr) <> "" Potem
xRg.Vrednost = xArr(xFArr)
Nastavi xRg = xRg.Offset(ColumnOffset:=1)
Konec Če
Naslednji
Konec Če
Naslednji
Naslednji
Konec Če
Application.ScreenUpdating = Res
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
kako narediti, če moja datoteka Txt vsebuje razmejeno z vejico?
Ta komentar je moderator na spletnem mestu minimiziral
Uporabite lahko funkcijo Find and Replace, da najprej zamenjate vejico s presledkom, in uporabite eno od zgornjih metod, da jo pretvorite v datoteko Excel.
Ta komentar je moderator na spletnem mestu minimiziral
Ali ni mogoče to spremeniti v kodi? To bi moral narediti s 130 datotekami
Ta komentar je moderator na spletnem mestu minimiziral
Isto vprašanje
Ta komentar je moderator na spletnem mestu minimiziral
Za tiste, ki še vedno potrebujejo pomoč pri tem, zamenjajte xArr = Split(xRg.Text, " ") z xArr = Split(xRg.Text, ",").
Ta komentar je moderator na spletnem mestu minimiziral
Ko zaženem modul, kot je dano, doda vsako datoteko .txt kot nov list, ne kot novo vrstico obstoječemu listu. Ali obstaja način, da to dosežete kot rezultat namesto novih listov za vsako datoteko .txt?
Ta komentar je moderator na spletnem mestu minimiziral
Ali mislite združiti vso besedilno datoteko na en list?
Ta komentar je moderator na spletnem mestu minimiziral
Ja, to želim tudi jaz.
Ta komentar je moderator na spletnem mestu minimiziral
Živjo, Davider, poskusiš lahko pod kodo 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
Ta komentar je moderator na spletnem mestu minimiziral
Koda je zelo koristna, to je edina koda, ki sem jo našel in ki množične datoteke txt, popravek, ki ga potrebujem, iščeta tudi Joyce in Davinder.
To je, da ekstrahirate datoteke .txt in jih vse prilepite eno pod drugo v določen stolpec, recimo stolpec 'N'.

Prav tako morate vedeti, ali bo mogoče dodati "pogoj če" za uvožene datoteke .txt, kot sledi.
če se datoteke .txt začnejo s črko "A", jih je treba prilepiti na "list 1", ki se začne s celico "N2"
in če se datoteke .txt začnejo s črko 'B', potem prilepite na 'List 2', začenši s celico 'N2'
drugače MsgBox naj bo "Neprepoznan namen datoteke .txt".

Hvala v naprej
Ta komentar je moderator na spletnem mestu minimiziral
Ta koda mi je delovala, a vseeno moram nekaj v njej spremeniti.

*Želim, da ga prilepite na isti list brez odpiranja novega lista, nato pa ga kopirate, ker traja dlje časa.

*treba vstaviti pogoj, če za uvožene datoteke txt, ki jih želite prilepiti na list 1, če se začne s črko A, in uvoziti na list 2, če se začne s črko B


Subtestcopy3()
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim i as Long
Zatemni zadnjo vrstico tako dolgo
Dim Rng kot domet
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Če je xFile = "" Potem
MsgBox "Ni najdenih datotek", vbInformation, "Kutools za Excel"
Exit Sub
Konec Če
Naredi, medtem ko xFile <> ""
xFiles.Dodaj xFile, xFile
xFile = Dir()
Zanka
Obseg("N2").Izberi
Nastavite xToBook = Ta delovni zvezek
Če je xFiles.Count > 0 Potem
Za i = 1 Do xFiles.Count
Nastavi xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Aktiviraj
'Izbira in kopiranje podatkov txt
Obseg(Izbor, Izbor.Konec(xlDown)).Izberi
Izbor. Kopija
xToBook.Aktiviraj
ActiveSheet.Prilepi
Izbira.Konec(xlDown).Odmik(1).Izberi
On Error Resume Next
Ob napaki Pojdi na 0
xWb.Zapri False
Naslednji
Konec Če
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Oprosti, moje roke so vezane
Ta komentar je moderator na spletnem mestu minimiziral
Živjo, moja koda se izvaja, vendar uvozi samo prvo datoteko. Piše, da je prišlo do napake metode za kopiranje. Razhroščevalnik poudari naslednjo vrstico kode. Kaj idej?


xWb.Worksheets(1).Kopiraj po:=xToBook.Sheets(xToBook.Sheets.Count)
Ta komentar je moderator na spletnem mestu minimiziral
Imam enak problem, najdem kakšno rešitev?
Ta komentar je moderator na spletnem mestu minimiziral
Hej katie,
Vem, da je vaš komentar precej star, vendar sem se soočil z isto težavo in sem jo rešil takole: Modul je treba vstaviti v podmapo aktivnega projekta .xlsx. Naredil sem napako, ko sem kopiral kodo v podmapo mojega PERSONAL.XLSB, kamor običajno shranim svoje makre in tako je z drugimi makri, ne pa s tem.
Ta komentar je moderator na spletnem mestu minimiziral
Kako bi izbrisali liste v kodi vba, če ne želite dvojnikov pri ponovnem izvajanju modula?
Ta komentar je moderator na spletnem mestu minimiziral
Oprosti, Harsh, samo pazi, da se izogneš ponovnemu uvažanju.
Ta komentar je moderator na spletnem mestu minimiziral
zdravo, želim preprečiti odstranjevanje prejšnjih ničel v excelu.

Poskušal sem spodnjo kodo, vendar ne deluje


Subtest()
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim I As Long
Dim j Tako dolgo
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberi mapo"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Če je xFile = "" Potem
MsgBox "Ni najdenih datotek", vbInformation, "Kutools za Excel"
Exit Sub
Konec Če
Naredi, medtem ko xFile <> ""
xFiles.Dodaj xFile, xFile
xFile = Dir()
Zanka
Nastavite xToBook = Ta delovni zvezek
Če je xFiles.Count > 0 Potem
Za I = 1 Do xFiles.Count
Nastavi xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" 'To je, da naredite excel v besedilni obliki, preden prilepite podatke besedilne datoteke
xWb.Worksheets(1).Kopiraj po:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
Ob napaki Pojdi na 0
xWb.Zapri False
Naslednji
Konec Če
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Pooja, lahko poskusiš funkcijo Odstrani vodilne ničle Kutools za Excel, da po uvozu odstraniš vse vodilne ničle iz izbire.
Ta komentar je moderator na spletnem mestu minimiziral
ampak nočem odstraniti. Želim preprečiti odstranjevanje prejšnjih ničel.
Ta komentar je moderator na spletnem mestu minimiziral
Če želite obdržati vodilne ničle, jih lahko oblikujete kot obliko besedila z obliko celic.
Ta komentar je moderator na spletnem mestu minimiziral
Pozdravljeni, kako spremenite to kodo, da vstavite datoteke *.txt v vrstnem redu: 1,2,3,4,5,6,7,8,9,10,11 itd. Trenutno koda vstavlja datoteke na naslednji način:1,10,11,12,13,14,15,16,17,18,19,2,20,21, XNUMX itd. Hvala!
Ta komentar je moderator na spletnem mestu minimiziral
ali obstaja možnost, da iz imen datotek txt vzamete le določen del imen listov?

v skladu z zgornjo kodo je prevzelo celotno ime lista.
Ta komentar je moderator na spletnem mestu minimiziral
hvala lepa, sem opravila delo na Office 2007 excel
Ta komentar je moderator na spletnem mestu minimiziral
Živjo, moja koda se izvaja, vendar uvozi samo prvo datoteko. Piše, da je prišlo do napake metode za kopiranje. Razhroščevalnik poudari naslednjo vrstico kode. Kaj idej?


xWb.Worksheets(1).Kopiraj po:=xToBook.Sheets(xToBook.Sheets.Count)
Ta komentar je moderator na spletnem mestu minimiziral
Hej Martinho,
Imel sem isti problem in sem ga rešil tako, da sem spremenil to vrstico:
Nastavite xToBook = Ta delovni zvezek
do
Nastavite xToBook = ActiveWorkbook
Mogoče to pomaga.
Ta komentar je moderator na spletnem mestu minimiziral
0

potrebujem vašo pomoč, nimam pojma vba excel želim uvoziti več besedilnih datotek, kot je 13000. ime besedilne datoteke je enako kot celica na primer (c1=112, tako da je ime besedilne datoteke tudi 112) pomeni, da je besedilna datoteka 112 uvozi c112.
Ta komentar je moderator na spletnem mestu minimiziral
potrebujem vašo pomoč, nimam pojma vba excel želim uvoziti več besedilnih datotek, kot je 13000. ime besedilne datoteke je enako kot celica na primer (c1=112, tako da je ime besedilne datoteke tudi 112) pomeni, da je besedilna datoteka 112 uvozi c112.
Ta komentar je moderator na spletnem mestu minimiziral
Koda deluje, vendar uvozi vsako besedilno datoteko na nov zavihek v delovnem zvezku. Imate kakšno idejo, kje v kodi bi to lahko spremenili, da bi uvozili novo besedilno datoteko na isti delovni list pod podatki iz zadnje besedilne datoteke?
Ta komentar je moderator na spletnem mestu minimiziral
V spodnji kodi, če želim določiti mapo in ne izbrati poti ob vsakem uvozu besedilne datoteke, kakšno spremembo moram narediti

KODA VBA:

Sub ImportCSVsWithReference()
'Posodobi z Kutools forExcel20151214
Dim xSht kot delovni list
Dim xWb kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Ob napaki Pojdi na ErrHandler
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Nastavite xSht = ThisWorkbook.ActiveSheet
If MsgBox("Počisti obstoječi list pred uvozom?", vbYesNo, "Kutools for Excel") = vbYes Potem xSht.UsedRange.Clear
Application.ScreenUpdating = Napačno
xFile = Dir(xStrPath & "\" & "*.txt")
Naredi, medtem ko xFile <> ""
Nastavi xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Zapri False
xDatoteka = Dir
Zanka
Application.ScreenUpdating = Res
Exit Sub
ErrHandler:
MsgBox "brez datotek txt", , "Kutools za Excel"
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Pozdravljeni, poskusite spodnjo kodo
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" je pot do mape, iz katere lahko uvozite besedilno datoteko, spremenite jo po potrebi.
Ta komentar je moderator na spletnem mestu minimiziral
Pozdravljeni, hvala za vašo dragoceno kodo VBA.
Vendar pa potrebujem kodo za več datotek txt v 'posamezen list na delovnem listu, ne posameznega lista za vsako datoteko txt'.
Kaj naj uredim vašo kodo za svoj namen?

Hvala,
Ta komentar je moderator na spletnem mestu minimiziral
Pozdravljeni, poskusite spodnjo kodo
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
Ta komentar je moderator na spletnem mestu minimiziral
To deluje dobro. Toda ko uvozi, preimenuje liste z name.txt, kako naj ohrani samo ime, ne da bi listu dodal končnico .txt?
Ocenjeno 3.5 iz 5
Ta komentar je moderator na spletnem mestu minimiziral
V redu, nvm je našel odgovor z Googlovo pomočjo.
zamenjaj vrstico:
ActiveSheet.Name = xWb.Name
z:
ActiveSheet.Name = Left(xWb.Name,Len(xWb.Name)-4)
bi odstranil zadnje 4 črke iz imena lista. Učinkovito mi je dal, kar sem potreboval. ime brez .txt
Cheers
Ocenjeno 4 iz 5
Ta komentar je moderator na spletnem mestu minimiziral
spodnja koda lahko razdeli podatke v stolpce glede na presledek ali tabulator med uvozom besedilne datoteke na liste. Vendar ne želim ločenega zavihka za vsako txt datoteko, ampak bi jih rad vse na enem listu. Podatki so v isti obliki za vsako datoteko. . Kaj je mogoče spremeniti, da bo to vse na enem listu, namesto da je vsaka uvožena datoteka nov zavihek, hvaležna bi bila vsa pomoč

Sub ImportTextToExcel()
'PosodobitevExtendoffice20180911
Dim xWb kot delovni zvezek
Dim xToBook kot delovni zvezek
Zatemni xStrPath kot niz
Zatemni xFileDialog kot FileDialog
Zatemni xFile kot niz
Dim xFiles kot nova zbirka
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue kot niz
Dim xRg As Range
Dim xArr
Nastavite xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Izberite mapo [Kutools for Excel]"
Če je xFileDialog.Show = -1 Potem
xStrPath = xFileDialog.SelectedItems(1)
Konec Če
Če je xStrPath = "" Nato zapustite Sub
Če je desno (xStrPath, 1) <> "\" Potem je xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Če je xFile = "" Potem
MsgBox "Ni najdenih datotek", vbInformation, "Kutools za Excel"
Exit Sub
Konec Če
Naredi, medtem ko xFile <> ""
xFiles.Dodaj xFile, xFile
xFile = Dir()
Zanka
Nastavite xToBook = Ta delovni zvezek
On Error Resume Next
Application.ScreenUpdating = Napačno
Če je xFiles.Count > 0 Potem

Za I = 1 Do xFiles.Count
Nastavi xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiraj po:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Zapri False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Za xFNum = 1 do xIntRow
Nastavite xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Če je UBound(xArr) > 0 Potem
Za xFArr = 0 do UBound(xArr)
Če xArr(xFArr) <> "" Potem
xRg.Vrednost = xArr(xFArr)
Nastavi xRg = xRg.Offset(ColumnOffset:=1)
Konec Če
Naslednji
Konec Če
Naslednji
Naslednji
Konec Če
Application.ScreenUpdating = Res
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Živjo, Daniel, poskusi s spodnjo kodo, uvozi vse besedilne datoteke na en list z imenom Txt.
Upoštevajte naslednje: če je ime besedila enako imenu obstoječega lista, besedilna datoteka morda ne bo uvožena.
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


Tu še ni objavljenih komentarjev
Pustite vaše komentarje
Objava kot gost
×
Ocenite to objavo:
0   Znaki
Predlagane lokacije

Sledi nam

Copyright © 2009 - www.extendoffice.com. | Vse pravice pridržane. Poganja ga ExtendOffice. | Kazalo
Microsoft in logotip Office sta blagovni znamki ali registrirani blagovni znamki družbe Microsoft Corporation v ZDA in / ali drugih državah.
Zaščiteno s Sectigo SSL