Importere fil

Det behøver ikke være VBA, andre alternativer er også ok, så længde den kan tage alle .txt filer der ligger i en given mappe og klare det med det ønsket output

du kan gemme følgende som en .vbs fil. Du skal bare rette, startFolder til hvilken mappe du vil læse fra, samt beginText til hvilket "ord" den skal starte ved og outputFileName til navnet på dit regneark. Bemærk regnearket må ikke være åbent når scriptet kører da programmet ellers fejler.

startFolder="C:\test1"
beginText="test"
outputFileName="C:\test.xls"

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

Set objFSO = CreateObject("Scripting.FileSystemObject")
set folder = objFSO.getFolder(startfolder)

a=0
for each fil in folder.files
    doWrite = false
    set cf = fil.openAsTextStream()
    if right(fil.name,3)<>"txt" then exit for
    while not cf.AtEndOfStream
        tmp = cf.readline()
        if tmp = beginText then doWrite=true
        if doWrite then
            xlSheet.Cells(a+1, 1).Value = tmp
            xlSheet.Cells(a+1, 2).Value = fil.name
            a=a+1
        end if
    wend
next

xlSheet.SaveAs (outputFileName)
xlApp.quit()
cf.close
set cf=nothing
set xlApp = nothing
set fil = nothing

hmm, jeg tester det, men der kommer kun tomme excel filer,

jeg kører det på et mappet drev på en server, der er mellemrum i filnavnet, er det et problem, jeg kunne evt. sætte startmappen til '.' ved at have scriptet i sammen mappe?

er det bevidst du bruger fil i stedet for file?

ellers kanon arbejde du har lavet!

det burde ikke være noget problem med mellemrum mm.
Du kan evt prøve at sætte en følgende linie ind efter for each fil in folder.files:
    msgbox fil.name
så skriver den om den finder nogle filer. Hvis der ikke kommer nogle popupbokse, så er det fordi den ingen filer finder!

Det skal være fil.

her er et alternativ

Sub ProcessTextFiles()
Dim FS As FileSearch
Dim FilePath As String, FileSpec As String
Dim i As Long, Linetext As String
Dim lFNo As Long

'********Udfyldes af brugeren**********
FilePath = "C:\mintekstfolder"
FileSpec = "*.txt"
Linetext = "Starther:"
'***************************************

Set FS = Application.FileSearch
With FS
    .LookIn = FilePath
    .Filename = FileSpec
    .Execute
    If .FoundFiles.Count = 0 Then
        MsgBox ("Ingen filer fundet")
        Exit Sub
    End If
End With
For i = 1 To FS.FoundFiles.Count
    lFNo = FreeFile
    Open FS.FoundFiles(i) For Input As #lFNo
    While Not tekst Like Linetext
        Line Input #lFNo, tekst
    Wend
    While Not EOF(lFNo)
        i = i + 1
        ActiveSheet.Range("A1").Offset(i, 0) = tekst
        ActiveSheet.Range("A1").Offset(i, 1) = .FoundFiles
    Wend
    Close #lFNo
Next
End Sub

Tofte: jeg indsatte boksen og den kommer op med 1 filnavn import.vbs som jeg har kaldt scriptet. Der bliver dannet en excel fil med 3 blanke faneblade.

Bak:tak for indsatsen, men på første linie får jeg en fejl med Sub ProcessTextFiles() "Compile error: Invalid or unqualified reference"

Bak: det var ikke første linie, men 5 _sidste_, jeg fjernede . foran FoundFiles, så kunne det kører - Men det er en uendelig løkke, der indsætter 2 tomme felter først og så ca. 65.000 gange starter linietekst.

Tofte: jeg tror jeg har luret den uden at have løsningen, da mappen også indeholder andet end text filer, stopper dit script i stedet for at fortsætte til næste fil.

Tofte: jeg har ændret scriptet til:

startFolder="C:\test1"
beginText="test"
outputFileName="C:\test.xls"

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

Set objFSO = CreateObject("Scripting.FileSystemObject")
set folder = objFSO.getFolder(startfolder)
startFolder="C:\test1"
beginText="test"
outputFileName="C:\test.xls"

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

Set objFSO = CreateObject("Scripting.FileSystemObject")
set folder = objFSO.getFolder(startfolder)

a=0
for each fil in folder.files
    doWrite = false
    set cf = fil.openAsTextStream()
    if right(fil.name,3)<>"txt" then exit for
    while not cf.AtEndOfStream
        tmp = cf.readline()
        if tmp = beginText then doWrite=true
        if doWrite then
            xlSheet.Cells(a+1, 1).Value = tmp
            xlSheet.Cells(a+1, 2).Value = fil.name
            a=a+1
        end if
    wend
next

xlSheet.SaveAs (outputFileName)
xlApp.quit()
cf.close
set cf=nothing
set xlApp = nothing
set fil = nothing
xlSheet.SaveAs (outputFileName)
xlApp.quit()
cf.close
set cf=nothing
set xlApp = nothing
set fil = nothing

-------

Og får præcis hvad jeg vil have ud af det, men det er overdrevet langsomt, tager mellem 20 - 30 sek. per fil den indlæser, har du nogen optimeringsforslag?

hmm copy paste er åbenbart svært :) - Prøver igen
---------------------------------------------------
startFolder="C:\test1"
beginText="test"
outputFileName="C:\test.xls"

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

Set objFSO = CreateObject("Scripting.FileSystemObject")
set folder = objFSO.getFolder(startfolder)

a = 0
For Each fil In folder.Files
    doWrite = False
    Set cf = fil.openAsTextStream()
    If Right(fil.Name, 3) = "txt" Then
        While Not cf.AtEndOfStream
            tmp = cf.readline()
            If tmp = beginText Then doWrite = True
            If doWrite Then
                xlSheet.Cells(a + 1, 1).Value = tmp
                xlSheet.Cells(a + 1, 2).Value = fil.Name
                a = a + 1
            End If
        Wend
    End If
Next

xlSheet.SaveAs (outputFileName)
xlApp.quit()
cf.Close
Set cf = Nothing
Set xlApp = Nothing
Set fil = Nothing

hmm, kan se at der bør indsættes en doWrite = False efter første End If, men hjælper nok ikke på hastigheden...

ja, du har ret, det er en fejl programmet stopper. Men virker ovenstående?

ovenstående virker, men er langsom tager ca. 20 - 30 sek per fil med mellem 50 og 120 linier

Jeg fjernede msgboxen og hastigheden steg markant, desuden har jeg lige byttet rundt på et par linier, så den ikke importere startteksten:

----------------------------

startFolder="C:\test1"
beginText="test"
outputFileName="C:\test.xls"


Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set folder = objFSO.getFolder(startfolder)

a = 0
For Each fil In folder.Files
    doWrite = False
    Set cf = fil.openAsTextStream()
    If Right(fil.Name, 3) = "txt" Then
        While Not cf.AtEndOfStream
            tmp = cf.readline()
        If doWrite Then
            xlSheet.Cells(a + 1, 1).Value = tmp
            xlSheet.Cells(a + 1, 2).Value = fil.Name
            a = a + 1
        End If
        If tmp = beginText Then doWrite = True
        Wend
    End If
Next

xlSheet.SaveAs (outputFileName)
xlApp.quit()
cf.Close
Set cf = Nothing
Set xlApp = Nothing
Set fil = Nothing

--------
Kan man få den til at importere i et enkelt ark, så man kan nøjes med at opdatere sin pivot tabel og ikke skal lave en ny? :)

Her en min igen med et par fejlrettelser :-)
Den samler det hele i det ark makroen startes fra

Sub ProcessTextFiles()
Dim FS As FileSearch
Dim FilePath As String, FileSpec As String
Dim i As Long, Linetext As String
Dim lFNo As Long, LineFound As Boolean
Dim tekst, x As Long
'********Udfyldes af brugeren**********
FilePath = "I:\"
FileSpec = "*.txt"
Linetext = "starther:"
'***************************************

Set FS = Application.FileSearch
With FS
    .LookIn = FilePath
    .Filename = FileSpec
    .Execute
    If .FoundFiles.Count = 0 Then
        MsgBox ("Ingen filer fundet")
        Exit Sub
    End If
End With
For i = 1 To FS.FoundFiles.Count
    lFNo = FreeFile
    Open FS.FoundFiles(i) For Input As #lFNo
    While Not EOF(lFNo)
        Line Input #lFNo, tekst
        If tekst Like Linetext Then LineFound = True
        If LineFound = True And Not tekst Like Linetext Then
            x = x + 1
            ActiveSheet.Range("A1").Offset(x, 0) = tekst
            ActiveSheet.Range("A1").Offset(x, 1) = FS.FoundFiles(i)
        End If
    Wend
    LineFound = False
    Close #lFNo
Next
End Sub