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

Hur importerar jag flera textfiler från en mapp till ett kalkylblad?

För tillfällen har du här en mapp med flera textfiler. Vad du vill göra är att importera dessa textfiler till ett enda kalkylblad som nedan visas på skärmdumpen. Istället för att kopiera textfilerna en efter en, finns det några knep för att snabbt importera textfilerna från en mapp till ett ark?

Importera flera textfiler från en mapp till ett ark med VBA

Importera textfil till den aktiva cellen med Kutools för Excel bra idé3


Här är en VBA-kod som kan hjälpa dig att importera alla textfiler från en specifik mapp till ett nytt ark.

1. Aktivera en arbetsbok som du vill importera textfiler och tryck på Alt + F11 för att aktivera Microsoft Visual Basic för applikationer fönster.

2. klick Insert > Modulerna, kopiera och klistra in nedanför VBA-koden till Modulerna fönster.

VBA: Importera flera textfiler från en mapp till ett ark

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. Tryck F5 för att visa en dialogruta och välj en mapp som innehåller textfiler du vill importera. Se skärmdump:
doc importera textfiler från en mapp 1

4. klick OK. Sedan har textfilerna importerats till den aktiva arbetsboken som ett nytt ark separat.
doc importera textfiler från en mapp 2


Om du vill importera en textfil till en viss cell eller ett visst område kan du ansöka Kutools för ExcelÄr Infoga fil på markören verktyg.

Kutools för Excel, med mer än 300 praktiska funktioner, gör dina jobb enklare. 

Efter gratis installation Kutools för Excel, gör så här:

1. Välj en cell som du vill importera textfilen och klicka på Kutools Plus > Import Export > Infoga fil på markören. Se skärmdump:
doc importera textfiler från en mapp 3

2. Sedan öppnas en dialogruta, klicka Bläddra för att visa Välj en fil för att infogas i cellmarkörens positionsdialog, välj sedan Textfiler från listrutan och välj sedan textfilen du vill importera. Se skärmdump:
doc importera textfiler från en mapp 4

3. klick Öppen > Ok, och den angivna textfilen har infogats vid markörens position, se skärmdump:
doc importera textfiler från en mapp 5


De bästa Office-produktivitetsverktygen

Kutools för Excel löser de flesta av dina problem och ökar din produktivitet med 80%

  • återanvändning: Sätt snabbt i komplexa formler, diagram och allt som du har använt tidigare; Kryptera celler med lösenord; Skapa e-postlista och skicka e-post ...
  • Super Formula Bar (enkelt redigera flera rader med text och formel); Läslayout (enkelt läsa och redigera ett stort antal celler); Klistra in i filtrerat intervall...
  • Sammanfoga celler / rader / kolumner utan att förlora data; Delat cellinnehåll; Kombinera duplicerade rader / kolumner... Förhindra duplicerade celler; Jämför intervall...
  • Välj Duplicera eller Unikt Rader; Välj tomma rader (alla celler är tomma); Super Find och Fuzzy Find i många arbetsböcker; Slumpmässigt val ...
  • Exakt kopia Flera celler utan att ändra formelreferens; Skapa referenser automatiskt till flera ark; Sätt in kulor, Kryssrutor och mer ...
  • Extrahera text, Lägg till text, ta bort efter position, Ta bort mellanslag; Skapa och skriva ut personsökningstalsatser; Konvertera mellan celler innehåll och kommentarer...
  • Superfilter (spara och tillämpa filterscheman på andra ark); Avancerad sortering efter månad / vecka / dag, frekvens och mer; Specialfilter av fet, kursiv ...
  • Kombinera arbetsböcker och arbetsblad; Sammanfoga tabeller baserat på nyckelkolumner; Dela data i flera ark; Batchkonvertera xls, xlsx och PDF...
  • Mer än 300 kraftfulla funktioner. Stöder Office / Excel 2007-2021 och 365. Stöder alla språk. Enkel implementering i ditt företag eller organisation. Fullständiga funktioner 30 dagars gratis provperiod. 60 dagars pengarna tillbaka-garanti.
kte-flik 201905

Fliken Office ger ett flikgränssnitt till Office och gör ditt arbete mycket enklare

  • Aktivera flikredigering och läsning i Word, Excel, PowerPoint, Publisher, Access, Visio och Project.
  • Öppna och skapa flera dokument i nya flikar i samma fönster, snarare än i nya fönster.
  • Ökar din produktivitet med 50 % och minskar hundratals musklick för dig varje dag!
officetab botten
Sortera kommentarer efter
Kommentarer (46)
Klassad 4 av 5 · 1 betyg
Denna kommentar minimerades av moderatoren på webbplatsen
Delprov ()
'Uppdatering avExtendoffice6/7/2016
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I As Long
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Om xFile = "" Då
MsgBox "Inga filer hittades", vbInformation, "Kutools för Excel"
Exit Sub
End If
Gör medan xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
loop
Ställ in xToBook = ThisWorkbook
Om xFiles.Count > 0 Då
För I = 1 Till xFiles.Count
Ställ in xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiera efter:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
På Fel GoTo 0
xWb.Stäng Falskt
Nästa
End If
End Sub

den här koden hjälper men jag vill

tab, semikolon, space true hur man gör detta snälla hjälp mig
Denna kommentar minimerades av moderatoren på webbplatsen
Vill du behålla utrymmet (avgränsare) efter att du har konverterat textfilerna till ark?
Denna kommentar minimerades av moderatoren på webbplatsen
det är mitt problem också, den här koden är sann. men efter att ha konverterat textfiler till Excel, behåller den inte avgränsningstecken.
Denna kommentar minimerades av moderatoren på webbplatsen
Kan du ladda upp textfilen och resultatet du vill ha för mig?
Denna kommentar minimerades av moderatoren på webbplatsen
Jag har samma problem. txt-filerna är alla i separata ark och koden ignorerar utrymmet mellan de två kolumnerna
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, Des och PB Rama Murty, koden nedan kan dela upp data i kolumner baserat på mellanslag eller tabb medan textfil importeras till ark. Du kan göra ett försök.

Sub ImportTextToExcel()
'Uppdatering avExtendoffice20180911
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Om xFile = "" Då
MsgBox "Inga filer hittades", vbInformation, "Kutools för Excel"
Exit Sub
End If
Gör medan xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
loop
Ställ in xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Om xFiles.Count > 0 Då

För I = 1 Till xFiles.Count
Ställ in xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiera efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Stäng Falskt
xIntRow = ActiveCell.CurrentRegion.Rows.Count
För xFNum = 1 Till xIntRow
Ställ in xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Om UBound(xArr) > 0 Då
För xFArr = 0 Till UBound(xArr)
Om xArr(xFArr) <> "" Då
xRg.Value = xArr(xFArr)
Ställ in xRg = xRg.Offset(ColumnOffset:=1)
End If
Nästa
End If
Nästa
Nästa
End If
Application.ScreenUpdating = True
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Vilka ändringar behövs om du vill dela upp data i kolumner baserat på kommatecken
Denna kommentar minimerades av moderatoren på webbplatsen
Vilka ändringar behöver göras om jag behöver samla data i kolumner baserade på kommatecken?
Denna kommentar minimerades av moderatoren på webbplatsen
Jag använde detta och det fungerar men jag skulle vilja att allt sparas på ett ark eftersom varje ark är samma information, de är bara loggfiler från varje dag.
så jag måste kombinera
alla objekt i mappen till ett ark
Sub ImportCSVsWithReference()
'Uppdatering av KutoolforExcel20151214
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Vid fel GoTo ErrHandler
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
Ställ in xSht = ThisWorkbook.ActiveSheet
Om MsgBox("Rensa det befintliga arket innan du importerar?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
Gör medan xFile <> ""
Ställ in xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Stäng Falskt
xFile = Dir
loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "inga txt-filer", , "Kutools för Excel"
End Sub

och den här som använder mellanslag för att lägga till varje kolumn

Sub ImportTextToExcel()
'Uppdatering avExtendoffice20180911
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Om xFile = "" Då
MsgBox "Inga filer hittades", vbInformation, "Kutools för Excel"
Exit Sub
End If
Gör medan xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
loop
Ställ in xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Om xFiles.Count > 0 Då

För I = 1 Till xFiles.Count
Ställ in xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiera efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Stäng Falskt
xIntRow = ActiveCell.CurrentRegion.Rows.Count
För xFNum = 1 Till xIntRow
Ställ in xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Om UBound(xArr) > 0 Då
För xFArr = 0 Till UBound(xArr)
Om xArr(xFArr) <> "" Då
xRg.Value = xArr(xFArr)
Ställ in xRg = xRg.Offset(ColumnOffset:=1)
End If
Nästa
End If
Nästa
Nästa
End If
Application.ScreenUpdating = True
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
hur gör jag om min Txt-fil innehåller avgränsad med kommatecken?
Denna kommentar minimerades av moderatoren på webbplatsen
Du kan använda Sök och ersätt fuctuon för att ersätta kommatecken med blanksteg först, och tillämpa en av ovanstående metoder för att konvertera den till Excel-fil.
Denna kommentar minimerades av moderatoren på webbplatsen
Finns det inte något sätt att ändra detta i koden? Jag skulle behöva göra det här med 130 filer
Denna kommentar minimerades av moderatoren på webbplatsen
Samma fråga
Denna kommentar minimerades av moderatoren på webbplatsen
För de som fortfarande behöver hjälp med detta, ersätt xArr = Split(xRg.Text, " ") med xArr = Split(xRg.Text, ",").
Denna kommentar minimerades av moderatoren på webbplatsen
När jag kör modulen som angiven, lägger den till varje .txt-fil som ett nytt ark, inte som en ny rad till det befintliga arket. Finns det något sätt att uppnå det som utdata istället för nya ark för varje .txt-fil?
Denna kommentar minimerades av moderatoren på webbplatsen
Menar du att kombinera all textfil till ett ark?
Denna kommentar minimerades av moderatoren på webbplatsen
Ja det är vad jag vill också.
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, Davinder, du kan prova nedan vba-kod.
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
Denna kommentar minimerades av moderatoren på webbplatsen
Koden är till stor hjälp, det är den enda koden jag hittade som får txt-filer i bulk, den fix som jag behöver på den är också vad Joyce och Davinder är ute efter.
Det är att extrahera .txt-filerna och klistra in dem alla under varandra i en specifik kolumn, låt oss säga kolumn 'N'.

Behöver också veta om det kommer att vara möjligt att lägga till ett "om-villkor" för att importerade .txt-filer ska vara som följer.
om .txt-filerna börjar med bokstaven "A" ska de klistras in på "ark 1" som börjar med cell "N2"
och om .txt-filerna börjar med bokstaven 'B', klistra in på 'Sheet 2' som börjar med cell 'N2'
else MsgBox ska vara "Okänd .txt-filsyfte".

tack på förhand
Denna kommentar minimerades av moderatoren på webbplatsen
Jag har den här koden fungerat för mig men ändå måste jag ändra en del i den.

*Jag vill att det ska klistra in på samma ark utan att öppna ett nytt ark och sedan kopiera det eftersom det tar längre tid.

*måste infoga ett villkorligt if för importerade txt-filer för att klistras in på blad 1 om det börjar med bokstaven A och importeras till blad 2 om det börjar med bokstaven B


Sub testcopy3()
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim jag så länge
Dimma Last Row As Long
Dim Rng som intervall
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Om xFile = "" Då
MsgBox "Inga filer hittades", vbInformation, "Kutools för Excel"
Exit Sub
End If
Gör medan xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
loop
Range("N2"). Välj
Ställ in xToBook = ThisWorkbook
Om xFiles.Count > 0 Då
För i = 1 Till xFiles.Count
Ställ in xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Aktivera
'Välja och kopiera txt-data
Range(Selection, Selection.End(xlDown)).Välj
Selection.Copy
xToBook.Aktivera
ActiveSheet.Paste
Selection.End(xlDown).Offset(1).Välj
On Error Resume Next
På Fel GoTo 0
xWb.Stäng Falskt
Nästa
End If
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Förlåt, mina händer är bundna
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, min kod körs men importerar bara den första filen. Det står att det var ett metodfel för kopiering. Debuggern markerar följande kodrad. Några idéer?


xWb.Worksheets(1).Kopiera efter:=xToBook.Sheets(xToBook.Sheets.Count)
Denna kommentar minimerades av moderatoren på webbplatsen
Jag har samma problem, finns det några lösningar?
Denna kommentar minimerades av moderatoren på webbplatsen
Hej katie,
Jag vet att din kommentar är ganska gammal, men jag stod inför samma problem och fixade det så här: Modulen måste infogas i en undermapp till det aktiva .xlsx-projektet. Jag gjorde misstaget att kopiera koden till en undermapp av min PERSONAL.XLSB där jag vanligtvis lagrar mina makron och det gör det med mina andra makron, men inte med det här.
Denna kommentar minimerades av moderatoren på webbplatsen
Hur skulle du ta bort arken i vba-koden om du inte vill ha dubbletter vid omkörning av modulen?
Denna kommentar minimerades av moderatoren på webbplatsen
Förlåt, Harsh, var bara försiktig så att du undviker att importera upprepade gånger.
Denna kommentar minimerades av moderatoren på webbplatsen
hej jag vill förhindra att föregående nollor tas bort i excel.

Jag har försökt nedanstående kod men det fungerar inte


Delprov ()
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I As Long
Dim j As Long
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Om xFile = "" Då
MsgBox "Inga filer hittades", vbInformation, "Kutools för Excel"
Exit Sub
End If
Gör medan xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
loop
Ställ in xToBook = ThisWorkbook
Om xFiles.Count > 0 Då
För I = 1 Till xFiles.Count
Ställ in xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" 'Detta är för att göra Excel i textformat innan du klistrar in textfildata
xWb.Worksheets(1).Copy After:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
På Fel GoTo 0
xWb.Stäng Falskt
Nästa
End If
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Pooja, du kan prova funktionen Ta bort ledande nollor i Kutools för Excel för att ta bort alla inledande nollor från urvalet efter import.
Denna kommentar minimerades av moderatoren på webbplatsen
men jag vill inte ta bort. Jag vill förhindra att föregående nollor tas bort.
Denna kommentar minimerades av moderatoren på webbplatsen
Om du vill behålla de inledande nollorna kan du formatera dem som textformat med cellformat.
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, hur ändrar du den här koden för att infoga *.txt-filer i ordningsföljd: 1,2,3,4,5,6,7,8,9,10,11, etc. För närvarande infogar koden filer enligt följande:1,10,11,12,13,14,15,16,17,18,19,2,20,21, XNUMX, etc. Tack!
Denna kommentar minimerades av moderatoren på webbplatsen
finns det någon chans att ta arknamn bara vissa delar från txt-filnamn?

enligt ovanstående kod har hela arknamnet tagit.
Denna kommentar minimerades av moderatoren på webbplatsen
tack så mycket gjorde jobbet på office 2007 excel
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, min kod körs men importerar bara den första filen. Det står att det var ett metodfel för kopiering. Debuggern markerar följande kodrad. Några idéer?


xWb.Worksheets(1).Kopiera efter:=xToBook.Sheets(xToBook.Sheets.Count)
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Martinho,
Jag hade samma problem och löste det genom att ändra denna rad:
Ställ in xToBook = ThisWorkbook
till
Ställ in xToBook = ActiveWorkbook
Det kanske hjälper.
Denna kommentar minimerades av moderatoren på webbplatsen
0

jag behöver er hjälp jag har ingen aning om vba excel jag vill importera flera textfiler som 13000. textfilens namn är samma som cellen till exempel (c1=112 så textfilens namn är också 112) betyder att textfilen 112 är importera c112.
Denna kommentar minimerades av moderatoren på webbplatsen
jag behöver er hjälp jag har ingen aning om vba excel jag vill importera flera textfiler som 13000. textfilens namn är samma som cellen till exempel (c1=112 så textfilens namn är också 112) betyder att textfilen 112 är importera c112.
Denna kommentar minimerades av moderatoren på webbplatsen
Koden fungerar men importerar varje textfil till en ny flik i arbetsboken. Någon idé om var i koden detta kan ändras för att importera den nya textfilen på samma kalkylblad under data från den sista textfilen?
Denna kommentar minimerades av moderatoren på webbplatsen
I koden nedan om jag vill ange mappen istället för att välja sökvägen varje gång importera en textfil, vilken ändring måste göra

VBA-KOD:

Sub ImportCSVsWithReference()
'Uppdatering av KutoolforExcel20151214
Dim xSht Som arbetsblad
Dim xWb Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Vid fel GoTo ErrHandler
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
Ställ in xSht = ThisWorkbook.ActiveSheet
Om MsgBox("Rensa det befintliga arket innan du importerar?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.txt")
Gör medan xFile <> ""
Ställ in xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Stäng Falskt
xFile = Dir
loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "inga txt-filer", , "Kutools för Excel"
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, försök koden nedan
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" är mappsökvägen du kan importera textfil från, vänligen ändra den efter behov.
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, tack för din värdefulla VBA-kod.
Jag behöver dock en kod för flera txt-filer till "ett enda ark i kalkylbladet, inte ett individuellt ark för varje txt-fil".
Vad ska jag redigera din kod för mitt syfte?

Tack,
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, försök koden nedan
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
Denna kommentar minimerades av moderatoren på webbplatsen
Det här fungerar bra. Men när den importerar byter den namn på ark med name.txt hur får man det att behålla endast namn utan att lägga till .txt-tillägg till arket?
Klassad 3.5 av 5
Denna kommentar minimerades av moderatoren på webbplatsen
Ok nvm hittade svar med google hjälp.
ersätt linje:
ActiveSheet.Name = xWb.Name
med:
ActiveSheet.Name = Left(xWb.Name,Len(xWb.Name)-4)
skulle ta bort de fyra sista bokstäverna från arknamnet. Effektivt ge mig det jag behövde. namn utan .txt
Skål
Klassad 4 av 5
Denna kommentar minimerades av moderatoren på webbplatsen
koden nedan kan dela upp data i kolumner baserat på mellanslag eller tabb medan textfil importeras till ark. Men jag vill inte ha en separat flik för varje txt-fil jag vill ha dem alla under ett ark. Informationen är i samma format för varje fil. . Vad som kan ändras för att tillåta att allt är ett ark istället för att varje importerad fil är en ny flik. All hjälp skulle uppskattas

Sub ImportTextToExcel()
'Uppdatering avExtendoffice20180911
Dim xWb Som arbetsbok
Dim xToBook Som arbetsbok
Dim xStrPath som sträng
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Ställ in xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falskt
xFileDialog.Title = "Välj en mapp [Kutools för Excel]"
Om xFileDialog.Show = -1 Då
xStrPath = xFileDialog.SelectedItems(1)
End If
Om xStrPath = "" Avsluta Sub
If Right(xStrPath, 1) <> "\" Då xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Om xFile = "" Då
MsgBox "Inga filer hittades", vbInformation, "Kutools för Excel"
Exit Sub
End If
Gör medan xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
loop
Ställ in xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Om xFiles.Count > 0 Då

För I = 1 Till xFiles.Count
Ställ in xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopiera efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Stäng Falskt
xIntRow = ActiveCell.CurrentRegion.Rows.Count
För xFNum = 1 Till xIntRow
Ställ in xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Om UBound(xArr) > 0 Då
För xFArr = 0 Till UBound(xArr)
Om xArr(xFArr) <> "" Då
xRg.Value = xArr(xFArr)
Ställ in xRg = xRg.Offset(ColumnOffset:=1)
End If
Nästa
End If
Nästa
Nästa
End If
Application.ScreenUpdating = True
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, Daniel, försök nedanstående kod, den importerar alla textfiler i ett ark som heter Txt.
Observera att: om textnamnet är detsamma som det befintliga arknamnet kanske textfilen inte importeras.
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


Det finns inga kommentarer här ännu

Följ oss

Copyright © 2009 - www.extendoffice.com. | Alla rättigheter förbehållna. Drivs av ExtendOffice. | | Sitemap
Microsoft och Office-logotypen är varumärken eller registrerade varumärken som tillhör Microsoft Corporation i USA och / eller andra länder.
Skyddad av Sectigo SSL