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

Jak importovat více textových souborů ze složky do jednoho listu?

Například zde máte složku s více textovými soubory, co chcete udělat, je importovat tyto textové soubory do jednoho listu, jak je uvedeno níže. Místo kopírování textových souborů jeden po druhém, existují nějaké triky, jak rychle importovat textové soubory z jedné složky do jednoho listu?

Importujte více textových souborů z jedné složky do jednoho listu pomocí VBA

Importujte textový soubor do aktivní buňky pomocí Kutools pro Excel dobrý nápad3


Zde je kód VBA, který vám pomůže importovat všechny textové soubory z jedné konkrétní složky do nového listu.

1. Povolte sešit, do kterého chcete importovat textové soubory, a stiskněte Alt + F11 klíče k povolení Microsoft Visual Basic pro aplikace okno.

2. cvaknutí Vložit > Modulzkopírujte a vložte pod kód VBA do Modul okno.

VBA: Import více textových souborů z jedné složky do jednoho listu

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. lis F5 zobrazte dialogové okno a vyberte složku obsahující textové soubory, které chcete importovat. Viz screenshot:
doc importovat textové soubory ze složky 1

4. cvaknutí OK. Poté byly textové soubory importovány do aktivního sešitu jako nový list samostatně.
doc importovat textové soubory ze složky 2


Pokud chcete importovat jeden textový soubor do konkrétní buňky nebo oblasti, můžete použít Kutools pro ExcelJe Vložte soubor na kurzor utilita.

Kutools pro Excel, s více než 300 užitečné funkce, které vám usnadní práci. 

Po instalace zdarma Kutools pro Excel, prosím, postupujte takto:

1. Vyberte buňku, do které chcete importovat textový soubor, a klepněte na Kutools Plus > Import Export > Vložte soubor na kurzor. Viz snímek obrazovky:
doc importovat textové soubory ze složky 3

2. Poté se objeví dialogové okno, klepněte na Procházet pro zobrazení Vyberte soubor pro vložení do dialogového okna pozice kurzoru buňky, dále vyberte Textové soubory z rozevíracího seznamu a poté vyberte textový soubor, který chcete importovat. Viz screenshot:
doc importovat textové soubory ze složky 4

3. cvaknutí OTEVŘENO > Oka na pozici kurzoru byl vložen textový soubor, viz screenshot:
doc importovat textové soubory ze složky 5


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2019 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Kompletní funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50% a omezuje stovky kliknutí myší každý den!
officetab dno
Komentáře (41)
Zatím žádné hodnocení. Buďte první, kdo ohodnotí!
Tento komentář byl moderátorem webu minimalizován
Sub Test ()
'AktualizovatExtendoffice6 / 7 / 2016
Dim xWb jako sešit
Dim xToBook jako pracovní sešit
Dim xStrPath jako řetězec
Dim xFileDialog jako FileDialog
Dim xFile As String
Dim xFiles jako nová kolekce
Dim I As Long
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Vyberte složku [Kutools pro Excel]"
Pokud xFileDialog.Show = -1 Pak
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Pak Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Pokud xFile = "" Pak
MsgBox "Nebyly nalezeny žádné soubory", vbInformation, "Kutools pro Excel"
Konec Sub
End If
Dělat, zatímco xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Smyčka
Nastavit xToBook = ThisWorkbook
Pokud xFiles.Count > 0 Pak
Pro 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
Při chybě GoTo 0
xWb.Zavřít False
další
End If
End Sub

tento kód pomáhá, ale chci

tabulátor, středník, mezera true jak to udělat prosím pomozte mi
Tento komentář byl moderátorem webu minimalizován
Chcete zachovat mezeru (oddělovače) po převodu textových souborů na listy?
Tento komentář byl moderátorem webu minimalizován
to je i můj problém, tento kód je pravdivý. ale po převodu textových souborů do excelu nezachová oddělovače.
Tento komentář byl moderátorem webu minimalizován
Mohl byste nahrát textový soubor a výsledek, který pro mě chcete?
Tento komentář byl moderátorem webu minimalizován
Mám stejný problém. Soubory txt jsou všechny na samostatných listech a kód ignoruje mezeru mezi dvěma sloupci
Tento komentář byl moderátorem webu minimalizován
Dobrý den, Des a PB Rama Murty, níže uvedený kód může při importu textového souboru do listů rozdělit data do sloupců na základě mezery nebo tabulátoru. Můžete to zkusit.

Sub ImportTextToExcel()
'AktualizovatExtendoffice20180911
Dim xWb jako sešit
Dim xToBook jako pracovní sešit
Dim xStrPath jako řetězec
Dim xFileDialog jako FileDialog
Dim xFile As String
Dim xFiles jako nová kolekce
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg jako rozsah
Dim xArr
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Vyberte složku [Kutools pro Excel]"
Pokud xFileDialog.Show = -1 Pak
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Pak Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Pokud xFile = "" Pak
MsgBox "Nebyly nalezeny žádné soubory", vbInformation, "Kutools pro Excel"
Konec Sub
End If
Dělat, zatímco xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Smyčka
Nastavit xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Pokud xFiles.Count > 0 Pak

Pro I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Zavřít False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Pro xFNum = 1 To xIntRow
Nastavit xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Pokud UBound(xArr) > 0 Pak
Pro xFArr = 0 až UBound(xArr)
If xArr(xFArr) <> "" Pak
xRg.Value = xArr(xFArr)
Nastavit xRg = xRg.Offset(ColumnOffset:=1)
End If
další
End If
další
další
End If
Application.ScreenUpdating = True
End Sub
Tento komentář byl moderátorem webu minimalizován
Jaké změny jsou potřeba, pokud chcete rozdělit data do sloupců na základě čárky
Tento komentář byl moderátorem webu minimalizován
Jaké změny je třeba provést, pokud potřebuji tot data do sloupců na základě čárky?
Tento komentář byl moderátorem webu minimalizován
jak to udělat, pokud můj soubor Txt obsahuje oddělovač pomocí čárky?
Tento komentář byl moderátorem webu minimalizován
Pomocí funkce Najít a nahradit můžete nejprve nahradit čárku mezerou a pomocí jedné z výše uvedených metod ji převést na soubor aplikace Excel.
Tento komentář byl moderátorem webu minimalizován
Nejde to nějak změnit v kódu? Musel bych to udělat se 130 soubory
Tento komentář byl moderátorem webu minimalizován
Stejná otázka
Tento komentář byl moderátorem webu minimalizován
Pro ty, kteří s tím stále potřebují pomoc, nahraďte xArr = Split(xRg.Text, " ") za xArr = Split(xRg.Text, ",").
Tento komentář byl moderátorem webu minimalizován
Když spustím modul podle zadání, přidá každý soubor .txt jako nový list, nikoli jako nový řádek do existujícího listu. Existuje způsob, jak toho dosáhnout jako výstup namísto nových listů pro každý soubor .txt?
Tento komentář byl moderátorem webu minimalizován
Chcete sloučit všechny textové soubory do jednoho listu?
Tento komentář byl moderátorem webu minimalizován
Ano, to je to, co chci také.
Tento komentář byl moderátorem webu minimalizován
Ahoj, Davindere, můžeš to zkusit pod kódem 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
Tento komentář byl moderátorem webu minimalizován
Kód je velmi užitečný, je to jediný kód, který jsem našel a který hromadně dostává soubory txt. Oprava, kterou na něm potřebuji, je také to, co Joyce a Davinder hledají.
Je to extrahovat soubory .txt a vložit je všechny pod sebe do určitého sloupce, řekněme sloupce 'N'.

Také potřebujete vědět, zda bude možné přidat podmínku „if“ pro importované soubory .txt, aby byly následující.
pokud soubory .txt začínají písmenem „A“, vloží se na „list 1“ začínající buňkou „N2“
a pokud soubory .txt začínají písmenem „B“, vložte je na „List 2“ začínající buňkou „N2“
jinak MsgBox být "Nerozpoznaný účel souboru .txt".

Děkuji předem
Tento komentář byl moderátorem webu minimalizován
Tento kód mi fungoval, ale přesto v něm musím některé změnit.

*Chci, aby se vložil na stejný list bez otevírání nového listu a poté jej zkopíroval, protože to trvá déle.

*je třeba vložit podmínku, pokud se mají importované soubory txt vložit na list 1, pokud začíná písmenem A, a importovat do listu 2, pokud začíná písmenem B


Sub testcopy3()
Dim xWb jako sešit
Dim xToBook jako pracovní sešit
Dim xStrPath jako řetězec
Dim xFileDialog jako FileDialog
Dim xFile As String
Dim xFiles jako nová kolekce
Dim i tak dlouho
Dim LastRow As Long
Dim Rng As Range
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Vyberte složku [Kutools pro Excel]"
Pokud xFileDialog.Show = -1 Pak
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Pak Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Pokud xFile = "" Pak
MsgBox "Nebyly nalezeny žádné soubory", vbInformation, "Kutools pro Excel"
Konec Sub
End If
Dělat, zatímco xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Smyčka
Rozsah("N2").Vyberte
Nastavit xToBook = ThisWorkbook
Pokud xFiles.Count > 0 Pak
Pro i = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Aktivovat
'Výběr a kopírování dat txt
Rozsah (výběr, výběr.vlastní (xlDown))
Selection.Copy
xToBook.Activate
ActiveSheet.Paste
Selection.End(xlDown).Offset(1).Select
On Error Resume Next
Při chybě GoTo 0
xWb.Zavřít False
další
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Promiň, mám svázané ruce
Tento komentář byl moderátorem webu minimalizován
Ahoj, můj kód běží, ale importuje pouze první soubor. Říká, že došlo k chybě metody při kopírování. Ladicí program zvýrazní následující řádek kódu. Nějaké nápady?


xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
Tento komentář byl moderátorem webu minimalizován
Mám stejný problém, našli jste nějaké řešení?
Tento komentář byl moderátorem webu minimalizován
ahoj katie,
Vím, že váš komentář je docela starý, ale čelil jsem stejnému problému a vyřešil jsem to tímto způsobem: Modul musí být vložen do podsložky aktivního projektu .xlsx. Udělal jsem chybu, že jsem zkopíroval kód do podsložky mého PERSONAL.XLSB, kam obvykle ukládám svá makra, stejně jako s mými ostatními makry, ale ne s tímto.
Tento komentář byl moderátorem webu minimalizován
Jak byste odstranili listy v kódu vba, pokud nechcete, aby byly při opětovném spuštění modulu duplikáty?
Tento komentář byl moderátorem webu minimalizován
Promiňte, Harshi, buďte opatrní, abyste se vyhnuli opakovanému importu.
Tento komentář byl moderátorem webu minimalizován
ahoj, chci zabránit odstranění předchozích nul v aplikaci Excel.

Zkoušel jsem níže uvedený kód, ale nefunguje to


Sub Test ()
Dim xWb jako sešit
Dim xToBook jako pracovní sešit
Dim xStrPath jako řetězec
Dim xFileDialog jako FileDialog
Dim xFile As String
Dim xFiles jako nová kolekce
Dim I As Long
Dim j Jak dlouho
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Vyberte složku"
Pokud xFileDialog.Show = -1 Pak
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Pak Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Pokud xFile = "" Pak
MsgBox "Nebyly nalezeny žádné soubory", vbInformation, "Kutools pro Excel"
Konec Sub
End If
Dělat, zatímco xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Smyčka
Nastavit xToBook = ThisWorkbook
Pokud xFiles.Count > 0 Pak
Pro I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" 'Toto slouží k vytvoření excelu v textovém formátu před vložením dat textového souboru
xWb.Worksheets(1).Copy After:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
Při chybě GoTo 0
xWb.Zavřít False
další
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Poojo, můžete vyzkoušet funkci Odebrat úvodní nuly aplikace Kutools pro Excel k odstranění všech úvodních nul z výběru po importu.
Tento komentář byl moderátorem webu minimalizován
ale odstraňovat se mi nechce. Chci zabránit odstranění předchozích nul.
Tento komentář byl moderátorem webu minimalizován
Pokud chcete zachovat úvodní nuly, můžete je formátovat jako textový formát pomocí formátu buňky.
Tento komentář byl moderátorem webu minimalizován
Dobrý den, jak upravíte tento kód pro vkládání souborů *.txt v pořadí: 1,2,3,4,5,6,7,8,9,10,11 atd. Aktuálně kód vkládá soubory takto:1,10,11,12,13,14,15,16,17,18,19,2,20,21, XNUMX atd. Díky!
Tento komentář byl moderátorem webu minimalizován
existuje nějaká šance vzít názvy listů pouze určité části z názvů souborů txt?

podle výše uvedeného kódu převzal celý název listu.
Tento komentář byl moderátorem webu minimalizován
díky moc za práci v kanceláři 2007 excel
Tento komentář byl moderátorem webu minimalizován
Ahoj, můj kód běží, ale importuje pouze první soubor. Říká, že došlo k chybě metody při kopírování. Ladicí program zvýrazní následující řádek kódu. Nějaké nápady?


xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
Tento komentář byl moderátorem webu minimalizován
Ahoj Martinho,
Měl jsem stejný problém a vyřešil jsem to změnou tohoto řádku:
Nastavit xToBook = ThisWorkbook
na
Nastavte xToBook = ActiveWorkbook
Možná to pomůže.
Tento komentář byl moderátorem webu minimalizován
0

Potřebuji od vás pomoc Nemám tušení vba excel Chci importovat více textových souborů jako 13000. Název textového souboru je stejný jako například buňka (c1=112, takže název textového souboru je také 112) znamená, že textový soubor 112 je importujte c112.
Tento komentář byl moderátorem webu minimalizován
Potřebuji od vás pomoc Nemám tušení vba excel Chci importovat více textových souborů jako 13000. Název textového souboru je stejný jako například buňka (c1=112, takže název textového souboru je také 112) znamená, že textový soubor 112 je importujte c112.
Tento komentář byl moderátorem webu minimalizován
Kód funguje, ale importuje každý textový soubor na novou kartu v sešitu. Máte nápad, kde by to v kódu mohlo být změněno, aby se importoval nový textový soubor na stejném listu pod daty z posledního textového souboru?
Tento komentář byl moderátorem webu minimalizován
V níže uvedeném kódu, pokud chci specifikovat složku místo výběru cesty pokaždé, když importujete textový soubor, co musí úprava udělat

KÓD VBA:

Sub ImportCSVsWithReference()
'Aktualizace od Kutools for Excel20151214
Dim xSht jako pracovní list
Dim xWb jako sešit
Dim xStrPath jako řetězec
Dim xFileDialog jako FileDialog
Dim xFile As String
Při chybě GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Vyberte složku [Kutools pro Excel]"
Pokud xFileDialog.Show = -1 Pak
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Pak Exit Sub
Nastavit xSht = ThisWorkbook.ActiveSheet
If MsgBox("Vymazat existující list před importem?", vbYesNo, "Kutools pro Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.txt")
Dělat, zatímco xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Zavřít False
xFile = Dir
Smyčka
Application.ScreenUpdating = True
Konec Sub
ErrHandler:
MsgBox "žádné soubory txt", , "Kutools pro Excel"
End Sub
Tento komentář byl moderátorem webu minimalizován
Dobrý den, zkuste níže uvedený kód
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 cesta ke složce, ze které můžete importovat textový soubor, změňte ji podle potřeby.
Tento komentář byl moderátorem webu minimalizován
Dobrý den, děkujeme za váš cenný kód VBA.
Potřebuji však kód pro více souborů txt do „jednoho listu v listu, nikoli samostatného listu pro každý soubor txt“.
Co bych měl upravit váš kód pro můj účel?

Díky,
Tento komentář byl moderátorem webu minimalizován
Dobrý den, zkuste níže uvedený kód
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
Zatím zde nejsou žádné komentáře
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění