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

Hogyan importálhat több szövegfájlt egy mappából egy munkalapba?

Például itt van egy mappája, amely több szöveges fájlt tartalmaz, amit meg kell tennie, hogy ezeket a szöveges fájlokat egyetlen munkalapba importálja, az alábbi képernyőkép szerint. A szöveges fájlok egyesével történő másolása helyett vannak-e trükkök a szövegfájlok gyors importálására egy mappából egy lapra?

Több szöveges fájlt importálhat egy mappából egyetlen lapba a VBA segítségével

Szöveges fájl importálása az aktív cellába a Kutools for Excel alkalmazással jó ötlet3


Itt egy VBA-kód segíthet az összes szövegfájl importálásában egy adott mappából egy új munkalapba.

1. Engedélyezze a szövegfájlok importálásához szükséges munkafüzetet, majd nyomja meg az gombot Alt + F11 gombokat az engedélyezéshez Microsoft Visual Basic for Applications ablak.

2. kettyenés betétlap > Modulok, másolja és illessze be a VBA kód alá a Modulok ablak.

VBA: Több szövegfájl importálása egy mappából egy lapra

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. nyomja meg F5 párbeszédpanel megjelenítéséhez, és válassza ki az importálni kívánt szöveges fájlokat tartalmazó mappát. Lásd a képernyőképet:
doc importáljon szöveges fájlokat egy mappából 1

4. kettyenés OK. Ezután a szövegfájlokat külön új lapként importálták az aktív munkafüzetbe.
doc importáljon szöveges fájlokat egy mappából 2


Ha egy szövegfájlt szeretne importálni egy adott cellába vagy tartományba, akkor alkalmazhatja Kutools az Excel számára'S Fájl beszúrása a kurzorhoz hasznosság.

Kutools az Excel számára, Több mint 300 a praktikus funkciók megkönnyítik a munkáját. 

Után ingyenes telepítés Kutools for Excel, kérjük, tegye az alábbiak szerint:

1. Jelölje ki a cellát, amelybe importálni szeretné a szövegfájlt, majd kattintson a gombra Kutools Plus > Import Export > Fájl beszúrása a kurzorhoz. Lásd a képernyőképet:
doc importáljon szöveges fájlokat egy mappából 3

2. Ezután megjelenik egy párbeszédpanel, kattintson Tallózás megjeleníteni a Válasszon ki egy fájlt beillesztendő a cella kurzor pozíció párbeszédpanelen, válassza ki a következőt Szöveges fájlok a legördülő listából, majd válassza ki az importálni kívánt szövegfájlt. Lásd a képernyőképet:
doc importáljon szöveges fájlokat egy mappából 4

3. kettyenés Nyisd ki > Ok, és a szöveges fájl be lett illesztve a kurzor pozíciójába, lásd a képernyőképet:
doc importáljon szöveges fájlokat egy mappából 5


A legjobb irodai termelékenységi eszközök

A Kutools for Excel megoldja a legtöbb problémát, és 80% -kal növeli a termelékenységet

  • újrafelhasználás: Gyorsan helyezze be összetett képletek, diagramok és bármi, amit korábban használt; Cellák titkosítása jelszóval; Levelezőlista létrehozása és e-maileket küldeni ...
  • Szuper Formula Bár (könnyedén szerkeszthet több szöveget és képletet); Olvasás elrendezés (könnyen olvasható és szerkeszthető nagyszámú cella); Beillesztés a Szűrt tartományba...
  • Cellák / sorok / oszlopok egyesítése az adatok elvesztése nélkül; Osztott cellák tartalma; Kombinálja a duplikált sorokat / oszlopokat... megakadályozza az ismétlődő cellákat; Hasonlítsa össze a tartományokat...
  • Válassza a Másolat vagy az Egyedi lehetőséget Sorok; Válassza az Üres sorok lehetőséget (az összes cella üres); Super Find és Fuzzy Find sok munkafüzetben; Véletlenszerű kiválasztás ...
  • Pontos másolás Több cella a képletreferencia megváltoztatása nélkül; Automatikus referenciák létrehozása több lapra; Helyezze be a golyókat, Jelölőnégyzetek és még sok más ...
  • Kivonat szöveg, Szöveg hozzáadása, Eltávolítás pozíció szerint, Hely eltávolítása; Hozz létre és nyomtasson személyhívó részösszegeket; Konvertálás a cellatartalom és a megjegyzések között...
  • Szuper szűrő (mentse el és alkalmazza a szűrősémákat más lapokra); Haladó rendezés hónap / hét / nap, gyakoriság és egyebek szerint; Speciális szűrő félkövér, dőlt betűvel ...
  • Kombinálja a munkafüzeteket és a munkalapokat; Táblázatok egyesítése kulcsoszlopok alapján; Az adatok felosztása több lapra; Kötegelt konvertálás xls, xlsx és PDF...
  • Több mint 300 hatékony funkció. Támogatja az Office / Excel 2007-2021 és 365 verziókat. Minden nyelvet támogat. Könnyű üzembe helyezés vállalatában vagy szervezetében. Teljes funkciók 30 napos ingyenes próbaverzió. 60 napos pénzvisszafizetési garancia.
kte lap 201905

Az Office fül a füles felületet hozza az Office-ba, és sokkal könnyebbé teszi a munkáját

  • Füles szerkesztés és olvasás engedélyezése Wordben, Excelben és PowerPointban, Publisher, Access, Visio és Project.
  • Több dokumentum megnyitása és létrehozása ugyanazon ablak új lapjain, mint új ablakokban.
  • 50% -kal növeli a termelékenységet, és naponta több száz kattintással csökkenti az egér kattintását!
officetab alja
A megjegyzések rendezése szerint
Hozzászólások (46)
Az 4-t az 5-ből kiértékelte · 1 értékelés
A weboldal moderátora ezt a megjegyzést minimalizálta
Al Test ()
'Frissítés általExtendoffice6 / 7 / 2016
Dim xWb munkafüzetként
Dim xToBook munkafüzetként
Dim xStrPath karakterláncként
Dim xFileDialog mint FileDialog
Dim xFile As String
Dim xFiles Új gyűjteményként
Dim I As Long
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Hamis
xFileDialog.Title = "Válasszon ki egy mappát [Kutools for Excel]"
Ha xFileDialog.Show = -1 Akkor
xStrPath = xFileDialog.SelectedItems(1)
Ha véget
Ha xStrPath = "" Akkor lépjen ki a Sub
If Right(xStrPath, 1) <> "\" Akkor xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Ha xFile = "" Akkor
MsgBox "Nem található fájl", vbInformation, "Kutools for Excel"
Exit Sub
Ha véget
Csináld az xFile közben <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Hurok
Set xToBook = ThisWorkbook
Ha xFiles.Count > 0 Akkor
Ha I = 1 - xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Másolás után:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
Hiba történt GoTo 0
xWb.Close False
Következő
Ha véget
End Sub

ez a kód segít, de szeretném

tabulátor, pontosvessző, szóköz, igaz, hogyan kell ezt csinálni, kérem, segítsen
A weboldal moderátora ezt a megjegyzést minimalizálta
Meg akarja tartani a szóközt (határolójeleket) a szövegfájlok lapokká alakítása után?
A weboldal moderátora ezt a megjegyzést minimalizálta
ez az én problémám is, ez a kód igaz. de a szöveges fájlok excelre konvertálása után nem tartja meg a határolókat.
A weboldal moderátora ezt a megjegyzést minimalizálta
Fel tudnád tölteni nekem a szöveges fájlt és a kívánt eredményt?
A weboldal moderátora ezt a megjegyzést minimalizálta
Ugyanaz a problémám. A txt fájlok mindegyike külön lapon található, és a kód figyelmen kívül hagyja a két oszlop közötti szóközt
A weboldal moderátora ezt a megjegyzést minimalizálta
Helló, Des és PB Rama Murty! Az alábbi kód oszlopokra oszthatja az adatokat szóköz vagy tabulátor alapján, miközben szöveges fájlt importál lapokra. Egy próbát tehetsz.

Sub ImportTextToExcel()
'Frissítés általExtendoffice20180911
Dim xWb munkafüzetként
Dim xToBook munkafüzetként
Dim xStrPath karakterláncként
Dim xFileDialog mint FileDialog
Dim xFile As String
Dim xFiles Új gyűjteményként
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xrg mint tartomány
Dim xArr
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Hamis
xFileDialog.Title = "Válasszon ki egy mappát [Kutools for Excel]"
Ha xFileDialog.Show = -1 Akkor
xStrPath = xFileDialog.SelectedItems(1)
Ha véget
Ha xStrPath = "" Akkor lépjen ki a Sub
If Right(xStrPath, 1) <> "\" Akkor xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Ha xFile = "" Akkor
MsgBox "Nem található fájl", vbInformation, "Kutools for Excel"
Exit Sub
Ha véget
Csináld az xFile közben <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Hurok
Set xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = Hamis
Ha xFiles.Count > 0 Akkor

Ha I = 1 - xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Másolás után:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Ha xFNum = 1 - xIntRow
Set xRg = ActiveSheet.Range("A" & xFNum)
xArr = Felosztás(xRg.Szöveg, " ")
Ha UBound(xArr) > 0 Akkor
Ha xFArr = 0 - UBound(xArr)
Ha xArr(xFArr) <> "" Akkor
xRg.Érték = xArr(xFArr)
Beállítás xRg = xRg.Eltolás(Oszlopeltolás:=1)
Ha véget
Következő
Ha véget
Következő
Következő
Ha véget
Application.ScreenUpdating = Igaz
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Milyen változtatásokra van szükség, ha az adatokat vessző alapján oszlopokra szeretné osztani
A weboldal moderátora ezt a megjegyzést minimalizálta
Milyen változtatásokat kell tenni, ha az adatokat vessző alapján kell oszlopokba szednem?
A weboldal moderátora ezt a megjegyzést minimalizálta
Ezt használtam, és működik, de szeretném, ha az egészet egy lapra mentenék, mivel minden lap ugyanazt az információt tartalmazza, csak naplófájlok minden napról.
ezért kombinálnom kell a
a mappában lévő összes elemet egy lapra
Sub ImportCSVsWithReference()
'Frissítés: KutoolsforExcel20151214
Dim xWb munkafüzetként
Dim xToBook munkafüzetként
Dim xStrPath karakterláncként
Dim xFileDialog mint FileDialog
Dim xFile As String
Dim xFiles Új gyűjteményként
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xrg mint tartomány
Dim xArr
Hiba esetén GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Hamis
xFileDialog.Title = "Válasszon ki egy mappát [Kutools for Excel]"
Ha xFileDialog.Show = -1 Akkor
xStrPath = xFileDialog.SelectedItems(1)
Ha véget
Ha xStrPath = "" Akkor lépjen ki a Sub
If Right(xStrPath, 1) <> "\" Akkor xStrPath = xStrPath & "\"
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Törli a meglévő lapot importálás előtt?", vbYesNo, "Kutools for Excel") = vbYes Akkor xSht.UsedRange.Clear
Application.ScreenUpdating = Hamis
xFile = Dir(xStrPath & "\" & "*.log")
Csináld az xFile közben <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Eltolás(1)
xWb.Close False
xFile = Dir
Hurok
Application.ScreenUpdating = Igaz
Exit Sub
ErrHandler:
MsgBox "nincs txt fájl", , "Kutools for Excel"
End Sub

ez pedig szóközt használ a dd-hez minden oszlopban

Sub ImportTextToExcel()
'Frissítés általExtendoffice20180911
Dim xWb munkafüzetként
Dim xToBook munkafüzetként
Dim xStrPath karakterláncként
Dim xFileDialog mint FileDialog
Dim xFile As String
Dim xFiles Új gyűjteményként
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xrg mint tartomány
Dim xArr
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Hamis
xFileDialog.Title = "Válasszon ki egy mappát [Kutools for Excel]"
Ha xFileDialog.Show = -1 Akkor
xStrPath = xFileDialog.SelectedItems(1)
Ha véget
Ha xStrPath = "" Akkor lépjen ki a Sub
If Right(xStrPath, 1) <> "\" Akkor xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Ha xFile = "" Akkor
MsgBox "Nem található fájl", vbInformation, "Kutools for Excel"
Exit Sub
Ha véget
Csináld az xFile közben <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Hurok
Set xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = Hamis
Ha xFiles.Count > 0 Akkor

Ha I = 1 - xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Másolás után:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Ha xFNum = 1 - xIntRow
Set xRg = ActiveSheet.Range("A" & xFNum)
xArr = Felosztás(xRg.Szöveg, " ")
Ha UBound(xArr) > 0 Akkor
Ha xFArr = 0 - UBound(xArr)
Ha xArr(xFArr) <> "" Akkor
xRg.Érték = xArr(xFArr)
Beállítás xRg = xRg.Eltolás(Oszlopeltolás:=1)
Ha véget
Következő
Ha véget
Következő
Következő
Ha véget
Application.ScreenUpdating = Igaz
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
hogyan kell csinálni, ha a Txt fájlom vesszővel elválasztva van?
A weboldal moderátora ezt a megjegyzést minimalizálta
A Fuctuon keresése és cseréje segítségével először szóközzel helyettesítheti a vesszőt, majd a fenti módszerek valamelyikével konvertálhatja Excel-fájlba.
A weboldal moderátora ezt a megjegyzést minimalizálta
Ezt nem lehet valahogy megváltoztatni a kódban? Ezt 130 fájllal kellene megtennem
A weboldal moderátora ezt a megjegyzést minimalizálta
Ugyanaz a kérdés
A weboldal moderátora ezt a megjegyzést minimalizálta
Azok számára, akiknek továbbra is segítségre van szükségük ebben, cserélje ki az xArr = Split(xRg.Text, " ") szöveget az xArr = Split(xRg.Text, ",") értékre.
A weboldal moderátora ezt a megjegyzést minimalizálta
Amikor a megadott módon futtatom a modult, minden .txt fájlt új lapként ad hozzá, nem pedig új sorként a meglévő laphoz. Van mód ennek elérésére minden .txt fájl új lapjai helyett kimenetként?
A weboldal moderátora ezt a megjegyzést minimalizálta
Úgy érted, hogy az összes szövegfájlt egy lapra kell egyesíteni?
A weboldal moderátora ezt a megjegyzést minimalizálta
Igen, én is ezt szeretném.
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia, Davinder, a vba kód alatt kipróbálhatod.
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
A weboldal moderátora ezt a megjegyzést minimalizálta
A kód nagyon hasznos, ez az egyetlen olyan kód, amelyet találtam, amely tömegesen kapja meg a txt fájlokat. A javításra Joyce és Davinder is szükségem van.
Ez a .txt fájlok kibontása és beillesztése egymás alá egy adott oszlopba, mondjuk az „N” oszlopba.

Ezenkívül tudnia kell, hogy az importált .txt fájlokhoz a következőképpen lehet-e hozzáadni egy "ha feltételt".
ha a .txt fájlok „A” betűvel kezdődnek, akkor az „N1” cellával kezdődő „2. lapra” kell beilleszteni
és ha a .txt fájlok "B" betűvel kezdődnek, akkor illessze be a "2. lapra" az "N2" cellával kezdődően
különben az MsgBox az "Ismeretlen .txt fájl célja".

köszönöm előre
A weboldal moderátora ezt a megjegyzést minimalizálta
Nekem bevált ez a kód, de még változtatnom kell rajta.

* Azt akarom, hogy ugyanarra a lapra illessze be anélkül, hogy új lapot nyitna, majd másolja, mivel ez hosszabb időt vesz igénybe.

*feltételes if beszúrása szükséges az importált txt fájlok beillesztéséhez az 1. lapra, ha A betűvel kezdődik, és a 2. munkalapra importálva, ha B betűvel kezdődik


Altesztmásolat3()
Dim xWb munkafüzetként
Dim xToBook munkafüzetként
Dim xStrPath karakterláncként
Dim xFileDialog mint FileDialog
Dim xFile As String
Dim xFiles Új gyűjteményként
Dim i olyan hosszú
Dim LastRow As Long
Dim Rng mint tartomány
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Hamis
xFileDialog.Title = "Válasszon ki egy mappát [Kutools for Excel]"
Ha xFileDialog.Show = -1 Akkor
xStrPath = xFileDialog.SelectedItems(1)
Ha véget
Ha xStrPath = "" Akkor lépjen ki a Sub
If Right(xStrPath, 1) <> "\" Akkor xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Ha xFile = "" Akkor
MsgBox "Nem található fájl", vbInformation, "Kutools for Excel"
Exit Sub
Ha véget
Csináld az xFile közben <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Hurok
Tartomány("N2").Válassza ki
Set xToBook = ThisWorkbook
Ha xFiles.Count > 0 Akkor
Ha i = 1 - xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Aktiválás
'A txt adatok kiválasztása és másolása
Tartomány(Kiválasztás, Kiválasztás.Vége(xlLe)).Válassza ki
Selection.Copy
xToBook.Activate
ActiveSheet.Paste
Kijelölés.Vége(xlLe).Eltolás(1).Kiválasztás
On Error Resume Next
Hiba történt GoTo 0
xWb.Close False
Következő
Ha véget
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Elnézést, meg van kötve a kezem
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia, a kódom lefut, de csak az első fájlt importálja. Azt írja, hogy módszerhiba történt a másolásnál. A hibakereső a következő kódsort emeli ki. Bármilyen ötletet?


xWb.Worksheets(1).Másolás után:=xToBook.Sheets(xToBook.Sheets.Count)
A weboldal moderátora ezt a megjegyzést minimalizálta
Ugyanez a problémám, van valami megoldás?
A weboldal moderátora ezt a megjegyzést minimalizálta
szia katie,
Tudom, hogy a megjegyzésed elég régi, de én is ugyanezzel a problémával szembesültem, és így javítottam ki: A modult az aktív .xlsx projekt almappájába kell beilleszteni. Elkövettem azt a hibát, hogy bemásoltam a kódot a PERSONAL.XLSB fájl egy almappájába, ahol általában tárolom a makróimat, és ez történik a többi makrómmal, de ezzel nem.
A weboldal moderátora ezt a megjegyzést minimalizálta
Hogyan törölnéd a lapokat a vba kódban, ha nem akarsz duplikációkat a modul újrafuttatásakor?
A weboldal moderátora ezt a megjegyzést minimalizálta
Elnézést, Harsh, csak legyen óvatos, nehogy ismételten importáljon.
A weboldal moderátora ezt a megjegyzést minimalizálta
szia, szeretném megakadályozni a megelőző nullák eltávolítását az Excelben.

kipróbáltam az alábbi kódot, de nem működik


Al Test ()
Dim xWb munkafüzetként
Dim xToBook munkafüzetként
Dim xStrPath karakterláncként
Dim xFileDialog mint FileDialog
Dim xFile As String
Dim xFiles Új gyűjteményként
Dim I As Long
Dim j As Long
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Hamis
xFileDialog.Title = "Válasszon ki egy mappát"
Ha xFileDialog.Show = -1 Akkor
xStrPath = xFileDialog.SelectedItems(1)
Ha véget
Ha xStrPath = "" Akkor lépjen ki a Sub
If Right(xStrPath, 1) <> "\" Akkor xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Ha xFile = "" Akkor
MsgBox "Nem található fájl", vbInformation, "Kutools for Excel"
Exit Sub
Ha véget
Csináld az xFile közben <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Hurok
Set xToBook = ThisWorkbook
Ha xFiles.Count > 0 Akkor
Ha I = 1 - xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" 'Ez az Excel szöveges formátumúvá tétele a szövegfájl adatainak beillesztése előtt
xWb.Worksheets(1).Másolás után:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
Hiba történt GoTo 0
xWb.Close False
Következő
Ha véget
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Pooja, kipróbálhatja a Kutools for Excel Vezető nullák eltávolítása funkcióját, hogy az importálás után eltávolítsa az összes kezdő nullát a kijelölésből.
A weboldal moderátora ezt a megjegyzést minimalizálta
de nem akarom eltávolítani. Meg akarom akadályozni a megelőző nullák eltávolítását.
A weboldal moderátora ezt a megjegyzést minimalizálta
Ha meg szeretné tartani a kezdő nullákat, akkor azokat szövegformátumba formázhatja a Cell Format segítségével.
A weboldal moderátora ezt a megjegyzést minimalizálta
Hello, hogyan módosíthatja ezt a kódot, hogy a *.txt fájlokat sorrendben szúrja be: 1,2,3,4,5,6,7,8,9,10,11 stb. A kód jelenleg a következőképpen szúr be fájlokat:1,10,11,12,13,14,15,16,17,18,19,2,20,21, XNUMX stb. Köszönjük!
A weboldal moderátora ezt a megjegyzést minimalizálta
van esély arra, hogy a txt fájlnevekből a lapneveket csak bizonyos részeket vegyük át?

a fenti kód szerint a teljes lapnév foglalt.
A weboldal moderátora ezt a megjegyzést minimalizálta
köszönöm szépen az Office 2007 excel-en végzett munkát
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia, a kódom lefut, de csak az első fájlt importálja. Azt írja, hogy módszerhiba történt a másolásnál. A hibakereső a következő kódsort emeli ki. Bármilyen ötletet?


xWb.Worksheets(1).Másolás után:=xToBook.Sheets(xToBook.Sheets.Count)
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Martinho!
Nekem is volt ugyanez a problémám, és a következő sor megváltoztatásával oldottam meg:
Set xToBook = ThisWorkbook
nak nek
xToBook = ActiveWorkbook beállítása
Talán ez segít.
A weboldal moderátora ezt a megjegyzést minimalizálta
0

Segítségre van szükségem nincs ötletem vba excel több szöveges fájlt szeretnék importálni, például 13000. a szövegfájl neve megegyezik például a cellával (c1=112 tehát a szövegfájl neve is 112) azt jelenti, hogy a 112 szövegfájl importálja a c112-t.
A weboldal moderátora ezt a megjegyzést minimalizálta
Segítségre van szükségem nincs ötletem vba excel több szöveges fájlt szeretnék importálni, például 13000. a szövegfájl neve megegyezik például a cellával (c1=112 tehát a szövegfájl neve is 112) azt jelenti, hogy a 112 szövegfájl importálja a c112-t.
A weboldal moderátora ezt a megjegyzést minimalizálta
A kód működik, de minden szövegfájlt a munkafüzet új lapjára importál. Van valami ötleted, hogy a kódban hol lehetne ezt megváltoztatni, hogy az új szöveges fájlt ugyanazon a munkalapon importálják az utolsó szövegfájl adatai alá?
A weboldal moderátora ezt a megjegyzést minimalizálta
Az alábbi kódban, ha a mappát szeretném megadni ahelyett, hogy az elérési utat választanám minden alkalommal, amikor szöveges fájlt importálok, mit kell módosítani

VBA KÓD:

Sub ImportCSVsWithReference()
'Frissítés: KutoolsforExcel20151214
Dim xSht Munkalapként
Dim xWb munkafüzetként
Dim xStrPath karakterláncként
Dim xFileDialog mint FileDialog
Dim xFile As String
Hiba esetén GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Hamis
xFileDialog.Title = "Válasszon ki egy mappát [Kutools for Excel]"
Ha xFileDialog.Show = -1 Akkor
xStrPath = xFileDialog.SelectedItems(1)
Ha véget
Ha xStrPath = "" Akkor lépjen ki a Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Törli a meglévő lapot importálás előtt?", vbYesNo, "Kutools for Excel") = vbYes Akkor xSht.UsedRange.Clear
Application.ScreenUpdating = Hamis
xFile = Dir(xStrPath & "\" & "*.txt")
Csináld az xFile közben <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Eltolás(1)
xWb.Close False
xFile = Dir
Hurok
Application.ScreenUpdating = Igaz
Exit Sub
ErrHandler:
MsgBox "nincs txt fájl", , "Kutools for Excel"
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia, próbáld ki az alábbi kódot
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

A "C:\Users\AddinsVM001\Desktop\test" a mappa elérési útja, ahonnan szöveges fájlt importálhat. Kérjük, módosítsa szükség szerint.
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia! Köszönjük az értékes VBA kódot.
Azonban szükségem van egy kódra több txt fájlhoz „egyetlen munkalapon a munkalapon, nem pedig minden egyes txt fájlhoz”.
Mit módosítsam a kódot a célomnak megfelelően?

Köszönöm,
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia, próbáld ki az alábbi kódot
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
A weboldal moderátora ezt a megjegyzést minimalizálta
Ez jól működik. De amikor importál, átnevezi a munkalapokat name.txt fájllal, hogyan teheti meg, hogy csak a név maradjon meg anélkül, hogy .txt kiterjesztést adna a laphoz?
Az 3.5-t az 5-ből kiértékelte
A weboldal moderátora ezt a megjegyzést minimalizálta
Ok nvm megtalálta a választ a Google segítségével.
sor cseréje:
ActiveSheet.Name = xWb.Name
val vel:
ActiveSheet.Name = Bal(xWb.Name,Len(xWb.Name)-4)
eltávolítja az utolsó 4 betűt a lap nevéből. Hatékonyan megadta, amire szükségem volt. név .txt nélkül
Egészségére
Az 4-t az 5-ből kiértékelte
A weboldal moderátora ezt a megjegyzést minimalizálta
az alábbi kód oszlopokra oszthatja az adatokat szóköz vagy tabulátor alapján, miközben szöveges fájlt importál lapokra. De nem akarok külön lapot minden txt fájlhoz, szeretném, ha mindegyik egy lap alatt lenne. Az információ minden fájl esetében azonos formátumú. . Mit lehet módosítani, hogy ez csak egy lap legyen, ahelyett, hogy minden importált fájl egy új lap legyen, bármilyen segítséget megköszönnénk

Sub ImportTextToExcel()
'Frissítés általExtendoffice20180911
Dim xWb munkafüzetként
Dim xToBook munkafüzetként
Dim xStrPath karakterláncként
Dim xFileDialog mint FileDialog
Dim xFile As String
Dim xFiles Új gyűjteményként
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xrg mint tartomány
Dim xArr
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Hamis
xFileDialog.Title = "Válasszon ki egy mappát [Kutools for Excel]"
Ha xFileDialog.Show = -1 Akkor
xStrPath = xFileDialog.SelectedItems(1)
Ha véget
Ha xStrPath = "" Akkor lépjen ki a Sub
If Right(xStrPath, 1) <> "\" Akkor xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Ha xFile = "" Akkor
MsgBox "Nem található fájl", vbInformation, "Kutools for Excel"
Exit Sub
Ha véget
Csináld az xFile közben <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Hurok
Set xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = Hamis
Ha xFiles.Count > 0 Akkor

Ha I = 1 - xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Másolás után:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Ha xFNum = 1 - xIntRow
Set xRg = ActiveSheet.Range("A" & xFNum)
xArr = Felosztás(xRg.Szöveg, " ")
Ha UBound(xArr) > 0 Akkor
Ha xFArr = 0 - UBound(xArr)
Ha xArr(xFArr) <> "" Akkor
xRg.Érték = xArr(xFArr)
Beállítás xRg = xRg.Eltolás(Oszlopeltolás:=1)
Ha véget
Következő
Ha véget
Következő
Következő
Ha véget
Application.ScreenUpdating = Igaz
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Daniel, próbáld ki az alábbi kódot, ez importálja az összes szöveges fájlt egy Txt nevű lapra.
Figyelje meg, hogy: ha a szövegnév megegyezik a meglévő lapnévvel, előfordulhat, hogy a szöveges fájl nem importálható.
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


Még senki sem írt megjegyzést
Hagyja meg észrevételeit
Feladás vendégként
×
Értékeld ezt a bejegyzést:
0   Karakterek
Javasolt helyek

Kövess minket

Copyright © 2009 - www.extendoffice.com. | Minden jog fenntartva. Powered by ExtendOffice. | Oldaltérkép
A Microsoft és az Office logó a Microsoft Corporation védjegyei vagy bejegyzett védjegyei az Egyesült Államokban és / vagy más országokban.
Sectigo SSL védi