Udtræk fra mange ark til ét

Hej

Du kan bl.a. bruge noget ala =[ss1.xls]Sheet1!$A2$2. så henter du dataen ind fra en fil til den fil hvor du har denne kode, du kan læse mere her:
http://www.microsoft.com/technet/prodtechnol/office/office2000/tips/exlink1.mspx
Der vises et eks. på hvordan man henter en cell fra en xls fil til en anden.

Det er ikke noget problem, når der skal hentes data ind fra et specifikt ark. Men her drejer det sig om et vilkårligt antal ark i en specifik folder.

Okay ja der skal man jo se om man kan lave noget i VB der evt kan læse hvad der ligger i denne folder af xls filer. men ligger data'en i de samme celler i de forskellige filer. ?!

Data ligger altid i de samme felter.

De ark der skal fodre listen med data, er automatisk genererede, og er altid opbygget ens. Det er kun filnavne og antal ark der varierer.

Jeg kunne forestille mig, at hvis jeg havde en .txt fil i folderen med XLS filerne, der indeholder resultatet af en DIR /B, kunne den bruges som range? - aber wie? :)

De filer, der er placeret i mappen, har de alle data liggende på samme Ark  - måske Ark1 eller?

Jeg tror godt det kan lade sig gøre - vil gøre et forsøg....

Ja - altid på ark1 :)

Koden anbringes i ThisWorkbook:

rem Skal tilpasses til din mappe
Const mappe = "C:\Documents and Settings\pb\Skrivebord\0203HentFraArk\Test"

Dim samlRæk
Sub workbook_activate()
    ActiveWorkbook.Sheets(1).Activate
   
    samlRæk = 1
    søgiFolder
   
    Columns.AutoFit
    Cells(1, 1).Select
   
    MsgBox ("Opsamling afsluttet")
End Sub
Private Function søgiFolder()
Dim fs, f, f1, fc, s
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappe)
    Set fc = f.Files
    For Each f1 In fc
        hentData f1.Name
    Next
    søgNyeste = nyestefil
End Function
Sub hentData(filNavn)
Dim Xls, antalRæk
   
    Set Xls = CreateObject("Excel.Application")
    With Xls
        .Workbooks.Open mappe + "\" + filNavn
        antalRæk = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To antalRæk
            ActiveWorkbook.Sheets(1).Cells(samlRæk, 1) = filNavn
            ActiveWorkbook.Sheets(1).Cells(samlRæk, 2) = .Cells(r, 1)
            ActiveWorkbook.Sheets(1).Cells(samlRæk, 3) = .Cells(r, 2)
            ActiveWorkbook.Sheets(1).Cells(samlRæk, 4) = .Cells(r, 3)

rem Udbyg selv de celler, som skal overføres
            samlRæk = samlRæk + 1
        Next r
    End With
   
    Xls.Quit
    Set Xls = Nothing
End Sub

Den er dælme tæt på at være i mål :)

Nu er det nogle ret omfattende regneark, og jeg har kun brug for at importere data fra nogle specifikke celler. Feks A5, A6, B10, C10 og D5

Som den er nu, tager den rub og stup med.

Kan du fikse den? :)

På forhånd tak :)

Ja - vender tilbage

Sidste SUB erstattes med denne:

Sub hentData(filNavn)
Dim Xls, antalRæk
   
    Set Xls = CreateObject("Excel.Application")
    With Xls
        .Workbooks.Open mappe + "\" + filNavn
        ActiveWorkbook.Sheets(1).Cells(samlRæk, 1) = filNavn            '.cells(RækkeNr,KolonneNr)
        ActiveWorkbook.Sheets(1).Cells(samlRæk, 2) = .Cells(5, 1)      'A5
        ActiveWorkbook.Sheets(1).Cells(samlRæk, 3) = .Cells(6, 1)      'A6
        ActiveWorkbook.Sheets(1).Cells(samlRæk, 4) = .Cells(10, 2)      'B10
        ActiveWorkbook.Sheets(1).Cells(samlRæk, 5) = .Cells(10, 3)      'C10
        ActiveWorkbook.Sheets(1).Cells(samlRæk, 6) = .Cells(5, 4)      'D5

        samlRæk = samlRæk + 1
    End With
   
    Xls.Quit
    Set Xls = Nothing
End Sub

Super - jeg tjekker og vender tilbage.

Det spiller bare.

Tak for hjælpen.

Du må gerne lige smide et svar, så jeg kan få lukket spørgsmålet ned. :)

Fint - selv tak - det får du så...

Ja - lad os få lukket det ...

??? - er der ikke noget du har glemt???