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

Hvordan importeres flere tekstfiler fra en mappe til et regneark?

For eksempel har du her en mappe med flere tekstfiler, hvad du vil gøre er at importere disse tekstfiler til et enkelt regneark som vist nedenfor i skærmbilledet. I stedet for at kopiere tekstfilerne en efter en, er der nogle tricks til hurtigt at importere tekstfilerne fra en mappe til et ark?

Importer flere tekstfiler fra en mappe til et enkelt ark med VBA

Importer tekstfil til den aktive celle med Kutools til Excel god idé3


Her er en VBA-kode, der kan hjælpe dig med at importere alle tekstfiler fra en bestemt mappe til et nyt ark.

1. Aktivér en projektmappe, du vil importere tekstfiler, og tryk på Alt + F11 taster for at aktivere Microsoft Visual Basic til applikationer vindue.

2. klik indsatte > Moduler, kopier og indsæt nedenunder VBA-kode til Moduler vindue.

VBA: Importer flere tekstfiler fra en mappe til et 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. Trykke F5 for at få vist en dialog og vælge en mappe, der indeholder tekstfiler, du vil importere. Se skærmbillede:
doc importerer tekstfiler fra en mappe 1

4. klik OK. Derefter er tekstfilerne importeret til den aktive projektmappe som nyt ark separat.
doc importerer tekstfiler fra en mappe 2


Hvis du vil importere en tekstfil til en bestemt celle eller et bestemt område, kan du anvende Kutools til Excel's Indsæt fil på markøren nytte.

Kutools til Excel, med mere end 300 praktiske funktioner, der gør dine job lettere. 

Efter gratis installation Kutools til Excel, gør venligst som nedenfor:

1. Vælg en celle, du vil importere tekstfilen, og klik på Kutools Plus > Import Eksport > Indsæt fil på markøren. Se skærmbillede:
doc importerer tekstfiler fra en mappe 3

2. Derefter vises en dialogboks, klik Gennemse for at vise Vælg en fil skal indsættes i cellemarkørens placeringsdialog, vælg derefter Tekstfiler fra rullelisten, og vælg derefter den tekstfil, du vil importere. Se skærmbillede:
doc importerer tekstfiler fra en mappe 4

3. klik Åbne > Ok, og den angivne tekstfil er indsat ved markørpositionen, se skærmbillede:
doc importerer tekstfiler fra en mappe 5


De bedste Office-produktivitetsværktøjer

Kutools til Excel løser de fleste af dine problemer og øger din produktivitet med 80%

  • Genbruge: Indsæt hurtigt komplekse formler, diagrammer og alt, hvad du har brugt før; Krypter celler med adgangskode Opret postliste og send e-mails ...
  • Super formel bar (let redigere flere linjer med tekst og formel); Læsning Layout (let at læse og redigere et stort antal celler); Indsæt til filtreret rækkevidde...
  • Flet celler / rækker / kolonner uden at miste data; Split celler indhold; Kombiner duplikerede rækker / kolonner... Forhindre duplikerede celler; Sammenlign områder...
  • Vælg Duplicate eller Unique Rækker; Vælg tomme rækker (alle celler er tomme); Super Find og Fuzzy Find i mange arbejdsbøger; Tilfældig valg ...
  • Præcis kopi Flere celler uden at ændre formelreference; Auto Opret referencer til flere ark; Indsæt kugler, Afkrydsningsfelter og mere ...
  • Uddrag tekst, Tilføj tekst, Fjern efter position, Fjern mellemrum; Opret og udskriv personsøgningssubtotaler; Konverter mellem celler indhold og kommentarer...
  • Superfilter (gem og anvend filterskemaer på andre ark); Avanceret sortering efter måned / uge / dag, hyppighed og mere; Specielt filter af fed, kursiv ...
  • Kombiner arbejdsbøger og arbejdsark; Fletabeller baseret på nøglekolonner; Opdel data i flere ark; Batch Konverter xls, xlsx og PDF...
  • Mere end 300 kraftfulde funktioner. Understøtter Office / Excel 2007-2021 og 365. Understøtter alle sprog. Nem implementering i din virksomhed eller organisation. Fuld funktioner 30-dages gratis prøveperiode. 60 dages pengene tilbage garanti.
kte-fane 201905

Fanen Office bringer en grænseflade til et kontor med Office, og gør dit arbejde meget lettere

  • Aktiver redigering og læsning af faner i Word, Excel, PowerPoint, Publisher, Access, Visio og Project.
  • Åbn og opret flere dokumenter i nye faner i det samme vindue snarere end i nye vinduer.
  • Øger din produktivitet med 50 % og reducerer hundredvis af museklik for dig hver dag!
officetab bund
Sorter kommentarer efter
Kommentarer (46)
Bedømt 4 ud af 5 · 1 vurderinger
Denne kommentar blev minimeret af moderatoren på webstedet
Sub-test ()
'Opdatering afExtendoffice6 / 7 / 2016
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I Så længe
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Hvis xFile = "" Så
MsgBox "Ingen filer fundet", vbInformation, "Kutools til Excel"
Exit Sub
End If
Gør mens xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Indstil xToBook = ThisWorkbook
Hvis xFiles.Count > 0 Så
For I = 1 Til xFiles.Count
Indstil xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopier efter:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
På Fejl GoTo 0
xWb.Luk Falsk
Næste
End If
End Sub

denne kode hjælper, men jeg vil gerne

faneblad, semikolon, mellemrum sandt hvordan man gør dette venligst hjælp mig
Denne kommentar blev minimeret af moderatoren på webstedet
Vil du beholde mellemrummet (afgrænserne) efter konvertering af tekstfilerne til ark?
Denne kommentar blev minimeret af moderatoren på webstedet
det er også mit problem, denne kode er sand. men efter at have konverteret tekstfiler til Excel, beholder den ikke afgrænsningerne.
Denne kommentar blev minimeret af moderatoren på webstedet
Kunne du uploade tekstfilen og det resultat, du ønsker for mig?
Denne kommentar blev minimeret af moderatoren på webstedet
Jeg har samme problem. txt-filerne er alle i separate ark, og koden ignorerer mellemrummet mellem de to kolonner
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, Des og PB Rama Murty, nedenstående kode kan opdele data i kolonner baseret på mellemrum eller tabulator, mens tekstfil importeres til ark. Du kan prøve.

Sub ImportTextToExcel()
'Opdatering afExtendoffice20180911
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I Så længe
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Hvis xFile = "" Så
MsgBox "Ingen filer fundet", vbInformation, "Kutools til Excel"
Exit Sub
End If
Gør mens xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Indstil xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Hvis xFiles.Count > 0 Så

For I = 1 Til xFiles.Count
Indstil xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopier efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Luk Falsk
xIntRow = ActiveCell.CurrentRegion.Rows.Count
For xFNum = 1 Til xIntRow
Indstil xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Hvis UBound(xArr) > 0 Så
For xFArr = 0 Til UBound(xArr)
Hvis xArr(xFArr) <> "" Så
xRg.Value = xArr(xFArr)
Indstil xRg = xRg.Offset(ColumnOffset:=1)
End If
Næste
End If
Næste
Næste
End If
Application.ScreenUpdating = True
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Hvilke ændringer er nødvendige, hvis du vil opdele data i kolonner baseret på komma
Denne kommentar blev minimeret af moderatoren på webstedet
Hvilke ændringer skal der foretages, hvis jeg har brug for data i kolonner baseret på komma?
Denne kommentar blev minimeret af moderatoren på webstedet
Jeg brugte dette, og det virker, men jeg vil gerne have det hele til at gemme på ét ark, da hvert ark er den samme information, de er bare logfiler fra hver dag.
så jeg skal kombinere
alle elementer i mappen til ét ark
Sub ImportCSVsWithReference()
'Opdatering af KutoolforExcel20151214
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I Så længe
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Ved fejl Gå til ErrHandler
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
Indstil xSht = ThisWorkbook.ActiveSheet
Hvis MsgBox("Ryd det eksisterende ark før import?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
Gør mens xFile <> ""
Indstil xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Luk Falsk
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "ingen txt-filer", , "Kutools til Excel"
End Sub

og denne, der bruger mellemrum til at tilføje til hver kolonne

Sub ImportTextToExcel()
'Opdatering afExtendoffice20180911
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I Så længe
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Hvis xFile = "" Så
MsgBox "Ingen filer fundet", vbInformation, "Kutools til Excel"
Exit Sub
End If
Gør mens xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Indstil xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Hvis xFiles.Count > 0 Så

For I = 1 Til xFiles.Count
Indstil xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopier efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Luk Falsk
xIntRow = ActiveCell.CurrentRegion.Rows.Count
For xFNum = 1 Til xIntRow
Indstil xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Hvis UBound(xArr) > 0 Så
For xFArr = 0 Til UBound(xArr)
Hvis xArr(xFArr) <> "" Så
xRg.Value = xArr(xFArr)
Indstil xRg = xRg.Offset(ColumnOffset:=1)
End If
Næste
End If
Næste
Næste
End If
Application.ScreenUpdating = True
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
hvordan gør jeg, hvis min Txt-fil indeholder afgrænset med komma?
Denne kommentar blev minimeret af moderatoren på webstedet
Du kan bruge Find og Erstat fuctuon til at erstatte kommaet med mellemrum først, og anvende en af ​​ovenstående metoder til at konvertere det til Excel-fil.
Denne kommentar blev minimeret af moderatoren på webstedet
Er der ikke en måde at ændre dette på i koden? Jeg skulle gøre dette med 130 filer
Denne kommentar blev minimeret af moderatoren på webstedet
Samme spørgsmål
Denne kommentar blev minimeret af moderatoren på webstedet
For dem, der stadig har brug for hjælp til dette, skal du erstatte xArr = Split(xRg.Text, " ") med xArr = Split(xRg.Text, ",").
Denne kommentar blev minimeret af moderatoren på webstedet
Når jeg kører modulet som givet, tilføjer det hver .txt-fil som et nyt ark, ikke som en ny linje til det eksisterende ark. Er der en måde at opnå det som output i stedet for nye ark for hver .txt-fil?
Denne kommentar blev minimeret af moderatoren på webstedet
Mener du at kombinere al tekstfil til ét ark?
Denne kommentar blev minimeret af moderatoren på webstedet
Ja det er også det jeg vil have.
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, Davinder, du kan prøve nedenstående vba-kode.
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
Denne kommentar blev minimeret af moderatoren på webstedet
Koden er meget nyttig, det er den eneste kode, jeg fandt, som får txt-filer i bulk, den rettelse, jeg har brug for på den, er også det, som Joyce og Davinder leder efter.
Det er at udpakke .txt-filerne og indsætte dem alle under hinanden i en bestemt kolonne, lad os sige kolonne 'N'.

Har også brug for at vide, om det vil være muligt at tilføje en "hvis betingelse" for, at de importerede .txt-filer er som følger.
hvis .txt-filerne starter med bogstavet 'A', skal de indsættes på 'ark 1' begyndende med celle 'N2'
og hvis .txt-filerne starter med bogstavet 'B', så indsæt på 'Sheet 2' startende med celle 'N2'
ellers skal MsgBox være "Ugenkendt .txt-filformål".

På forhånd tak
Denne kommentar blev minimeret af moderatoren på webstedet
Jeg har fået denne kode til at fungere for mig, men jeg er stadig nødt til at ændre noget i den.

*Jeg vil have det til at indsætte på det samme ark uden at åbne et nyt ark og derefter kopiere det, da det tager længere tid.

*skal indsætte et betinget if for importerede txt-filer, der skal indsættes på ark 1, hvis det starter med bogstavet A og importeres til ark 2, hvis det starter med bogstavet B


Sub testcopy3()
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim jeg så længe
Dim Last Row As Long
Dim Rng Som Range
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Hvis xFile = "" Så
MsgBox "Ingen filer fundet", vbInformation, "Kutools til Excel"
Exit Sub
End If
Gør mens xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Range("N2"). Vælg
Indstil xToBook = ThisWorkbook
Hvis xFiles.Count > 0 Så
For i = 1 Til xFiles.Count
Indstil xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Aktiver
'Valg og kopiering af txt-data
Range(Udvalg, Valg.End(xlNed)).Vælg
Selection.Copy
xToBook.Activate
ActiveSheet.Paste
Selection.End(xlDown).Offset(1).Vælg
On Error Resume Next
På Fejl GoTo 0
xWb.Luk Falsk
Næste
End If
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Undskyld, mine hænder er bundet
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, min kode kører, men importerer kun den første fil. Den siger, at der var en metodefejl til kopiering. Debuggeren fremhæver følgende kodelinje. Nogle ideer?


xWb.Worksheets(1).Kopier efter:=xToBook.Sheets(xToBook.Sheets.Count)
Denne kommentar blev minimeret af moderatoren på webstedet
Jeg har det samme problem, findes der nogen løsninger?
Denne kommentar blev minimeret af moderatoren på webstedet
Hej katie,
Jeg ved, at din kommentar er ret gammel, men jeg stod over for det samme problem og fiksede det på denne måde: Modulet skal indsættes i en undermappe af det aktive .xlsx-projekt. Jeg lavede den fejl at kopiere koden ind i en undermappe af min PERSONAL.XLSB, hvor jeg normalt gemmer mine makroer, og det gør det med mine andre makroer, men ikke med denne.
Denne kommentar blev minimeret af moderatoren på webstedet
Hvordan ville du slette arkene i vba-koden, hvis du ikke vil have dubletter ved genudførelse af modulet?
Denne kommentar blev minimeret af moderatoren på webstedet
Beklager, hård, bare vær forsigtig med at undgå gentagne importer.
Denne kommentar blev minimeret af moderatoren på webstedet
hej jeg vil forhindre fjernelse af foregående nuller i excel.

Jeg har prøvet nedenstående kode, men det virker ikke


Sub-test ()
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I Så længe
Dim j As Long
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Hvis xFile = "" Så
MsgBox "Ingen filer fundet", vbInformation, "Kutools til Excel"
Exit Sub
End If
Gør mens xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Indstil xToBook = ThisWorkbook
Hvis xFiles.Count > 0 Så
For I = 1 Til xFiles.Count
Indstil xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" 'Dette er for at lave excel i tekstformat, før du indsætter tekstfildataene
xWb.Worksheets(1).Copy After:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
På Fejl GoTo 0
xWb.Luk Falsk
Næste
End If
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Pooja, du kan prøve funktionen Fjern ledende nuller i Kutools for Excel for at fjerne alle ledende nuller fra markeringen efter import.
Denne kommentar blev minimeret af moderatoren på webstedet
men jeg vil ikke fjerne. Jeg vil forhindre i at fjerne foregående nuller.
Denne kommentar blev minimeret af moderatoren på webstedet
Hvis du vil beholde de foranstillede nuller, kan du formatere dem som tekstformat med celleformat.
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, hvordan ændrer du denne kode for at indsætte *.txt-filer i rækkefølge: 1,2,3,4,5,6,7,8,9,10,11 osv. Koden indsætter i øjeblikket filer som følger:1,10,11,12,13,14,15,16,17,18,19,2,20,21, XNUMX osv. Tak!
Denne kommentar blev minimeret af moderatoren på webstedet
er der nogen chance for at tage arknavne kun visse dele fra txt-filnavne?

i henhold til ovenstående kode har hele arknavnet taget.
Denne kommentar blev minimeret af moderatoren på webstedet
mange tak gjorde jobbet på office 2007 excel
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, min kode kører, men importerer kun den første fil. Den siger, at der var en metodefejl til kopiering. Debuggeren fremhæver følgende kodelinje. Nogle ideer?


xWb.Worksheets(1).Kopier efter:=xToBook.Sheets(xToBook.Sheets.Count)
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Martinho,
Jeg havde det samme problem og løste det ved at ændre denne linje:
Indstil xToBook = ThisWorkbook
til
Indstil xToBook = ActiveWorkbook
Måske hjælper dette.
Denne kommentar blev minimeret af moderatoren på webstedet
0

jeg har brug for dig hjælp jeg har ingen idé om vba excel jeg vil importere flere tekstfiler som 13000. tekstfilnavnet er det samme som cellen for eksempel (c1=112 så tekstfilnavnet er også 112) betyder at tekstfilen 112 er importer c112.
Denne kommentar blev minimeret af moderatoren på webstedet
jeg har brug for dig hjælp jeg har ingen idé om vba excel jeg vil importere flere tekstfiler som 13000. tekstfilnavnet er det samme som cellen for eksempel (c1=112 så tekstfilnavnet er også 112) betyder at tekstfilen 112 er importer c112.
Denne kommentar blev minimeret af moderatoren på webstedet
Koden fungerer, men importerer hver tekstfil til en ny fane i projektmappen. Enhver idé om, hvor i koden dette kunne ændres for at importere den nye tekstfil på det samme regneark under dataene fra den sidste tekstfil?
Denne kommentar blev minimeret af moderatoren på webstedet
I nedenstående kode, hvis jeg vil angive mappen i stedet for at vælge stien hver gang importerer en tekstfil, hvilken ændring skal gøre

VBA KODE:

Sub ImportCSVsWithReference()
'Opdatering af KutoolforExcel20151214
Dim xSht som arbejdsark
Dim xWb Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Ved fejl Gå til ErrHandler
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Indstil xSht = ThisWorkbook.ActiveSheet
Hvis MsgBox("Ryd det eksisterende ark før import?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.txt")
Gør mens xFile <> ""
Indstil xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Luk Falsk
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "ingen txt-filer", , "Kutools til Excel"
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, prøv venligst nedenstående kode
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" er mappestien, du kan importere tekstfil fra, skift den efter behov.
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, tak for din værdifulde VBA-kode.
Jeg har dog brug for en kode for flere txt-filer til 'et enkelt ark i regnearket, ikke et individuelt ark for hver txt-fil'.
Hvad skal jeg redigere din kode til mit formål?

Tak,
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, prøv venligst nedenstående kode
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
Denne kommentar blev minimeret af moderatoren på webstedet
Dette fungerer fint. Men når den importerer, omdøber den ark med name.txt, hvordan får man det til at beholde kun navn uden at tilføje .txt-udvidelse til arket?
Bedømt 3.5 ud af 5
Denne kommentar blev minimeret af moderatoren på webstedet
Ok nvm fandt svar med google hjælp.
udskift linje:
ActiveSheet.Name = xWb.Name
med:
ActiveSheet.Name = Left(xWb.Name,Len(xWb.Name)-4)
ville fjerne de sidste 4 bogstaver fra arknavnet. Giver mig effektivt, hvad jeg havde brug for. navn uden .txt
Skål
Bedømt 4 ud af 5
Denne kommentar blev minimeret af moderatoren på webstedet
nedenstående kode kan opdele data i kolonner baseret på mellemrum eller tabulator, mens tekstfil importeres til ark. Men jeg vil ikke have en separat fane for hver txt-fil, jeg vil gerne have dem alle under ét ark. Oplysningerne er det samme format for hver fil. . Hvad kan ændres for at tillade, at det hele er ét ark i stedet for at hver fil importeret er en ny fane, enhver hjælp ville blive værdsat

Sub ImportTextToExcel()
'Opdatering afExtendoffice20180911
Dim xWb Som arbejdsbog
Dim xToBook Som arbejdsbog
Dim xStrPath som streng
Dim xFileDialog Som FileDialog
Dim xFile As String
Dim xFiles som ny samling
Dim I Så længe
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr
Indstil xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falsk
xFileDialog.Title = "Vælg en mappe [Kutools for Excel]"
Hvis xFileDialog.Show = -1 Så
xStrPath = xFileDialog.SelectedItems(1)
End If
Hvis xStrPath = "" Afslut Sub
Hvis Right(xStrPath, 1) <> "\" Så xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Hvis xFile = "" Så
MsgBox "Ingen filer fundet", vbInformation, "Kutools til Excel"
Exit Sub
End If
Gør mens xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Indstil xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Hvis xFiles.Count > 0 Så

For I = 1 Til xFiles.Count
Indstil xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Kopier efter:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Luk Falsk
xIntRow = ActiveCell.CurrentRegion.Rows.Count
For xFNum = 1 Til xIntRow
Indstil xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Hvis UBound(xArr) > 0 Så
For xFArr = 0 Til UBound(xArr)
Hvis xArr(xFArr) <> "" Så
xRg.Value = xArr(xFArr)
Indstil xRg = xRg.Offset(ColumnOffset:=1)
End If
Næste
End If
Næste
Næste
End If
Application.ScreenUpdating = True
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, Daniel, prøv nedenstående kode, den importerer alle tekstfiler i et ark med navnet Txt.
Bemærk: Hvis tekstnavnet er det samme som det eksisterende arknavn, importeres tekstfilen muligvis ikke.
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


Der er endnu ingen kommentarer her

Følg os

Copyright © 2009 - www.extendoffice.com. | Alle rettigheder forbeholdes. Drevet af ExtendOffice. | | Sitemap
Microsoft og Office-logoet er varemærker eller registrerede varemærker tilhørende Microsoft Corporation i USA og / eller andre lande.
Beskyttet af Sectigo SSL