Importere data fra mange Excel-regneark

Jeg har sådan noget kørende - et øjebik

Denne kode læser jo felter fra et Excel-ark:

    Dim Xl As Object
    Set Xl = CreateObject("EXCEL.APPLICATION")
    Xl.Workbooks.Open Fil, False, True
    A = Xl.range("A:1")
    B = Xl.range("B:1")
    ....

Derudover ville det selvfølgelig være en fordel, hvis du have alle filnavne i en tabel, som du kunne gennemløbe.
Men det er vel ikke tilfældet?

Kanon :o)

De kan vel læses ind i en tabel fra filbiblioteket :o)

Ja, denne kode aflæser alle filer i en mappe. Du behøver således ikke at indlæse dem i en tabel, man kan indkode din Excel-kode direkte heri:

Public Sub ListFiler(stDir As String)
Dim stName As String

    On Error GoTo err_FindFiler
   
    'List alle filer i denne mappe
    stName = Dir(stDir & "\*.*")
    Do While stName <> ""
        On Error Resume Next
        If (GetAttr(stDir & stName) And vbDirectory) <> vbDirectory Then
            'Er filen allerede åben opstår en fejl 5
            If Err.Number = 5 Then Err.Clear
           
            If stName <> "." Or stName <> ".." Then
                'placer filnavn et eller andet sted
                'her placeres det bare i debug-vinduet
                Debug.Print stName
            End If
        End If
        stName = Dir
    Loop
   
exit_FindFiler:
    Exit Sub
err_FindFiler:
    If Err.Number = 71 Then
        MsgBox AccessError(Err.Number) _
                    & "  Prøv venligst igen.  ", vbCritical + vbOKOnly, _
                    "Fejl ved læsning af drev " & stDir
    End If
    Resume exit_FindFiler
End Sub

Denne her læser alle de ønskede filer ind i en tabel

Sub FileSearch_EXCELL(soegmappe As String, soegsubs As Boolean, strextend As String, dropdbfilnavn As String, droptable As String, dropfield As String)
' Set Microsoft Office 9.0 Object Library before Executing this Sub
    Dim intI As Integer
    Dim cn As ADODB.Connection, rs As ADODB.Recordset
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=" & dropdbfilnavn & ";"
    ' Åben et recordset
    Set rs = New ADODB.Recordset
    rs.Open droptable, cn, adOpenKeyset, adLockOptimistic, adCmdTable
    ' alle records i en tabel
  With Application.FileSearch
    .NewSearch
    .LookIn = soegmappe
    .SearchSubFolders = soegsubs
    .FileName = strextend
    .MatchTextExactly = True
    .FileType = msoFileTypeAllFiles
   
  End With
 
  With Application.FileSearch
    If .Execute() > 0 Then
        MsgBox "Der blev fundet " & .FoundFiles.Count & " fil(er)."
       
        For intI = 1 To .FoundFiles.Count
            rs.AddNew ' tilføj ny record
            rs.Fields(dropfield) = .FoundFiles(intI)
            rs.Fields("filsize") = FileLen(.FoundFiles(intI)) / (1024 ^ 2)
            rs.Update ' gen den nye record
        Next intI
    Else
        MsgBox "Der blev ikke fundet nogen filer."
    End If
  End With
      rs.Close ' luk skidtet
    Set rs = Nothing
    cn.Close ' også her
    Set cn = Nothing
    ' slut prut finale
End Sub

Så skal vi blot åbne hver enkelt fil i tabell - hente data ud af arket og ind i en 3. tabel
kommer om lidt

Denne her åbner hvert ark - henter data ind. Denne viser det i en form,
men kan nemt laves om til at blive kaldt ovenfra, hvor man looper igennem f.eks. 1000 ark og adder data til en anden tabel.

Det kan tilrådes at gemme filnavne i en tabel, da sådan en operation godt kan tage 20 minutter for 1000 excell ark.

Private Sub Hentdata(filnavn)
Dim A As String, filnavn As String
Dim xApp As Object
   
  Set xApp = CreateObject("Excel.Application")
    xApp.Workbooks.Open FileName:=filnavn
    xApp.Sheets("AUTOKAL").Select
    'xApp.Visible = True
    xApp.Visible = False
    xApp.AskToUpdateLinks = True
    Me.filnavn = filnavn
    Me.BASISKODE = xApp.range("C8").Value
    Me.C1 = xApp.range("L44").Value
    Me.C2 = xApp.range("L56").Value
    Me.C3 = xApp.range("L69").Value
    Me.C4 = xApp.range("L75").Value
    Me.C5 = xApp.range("L103").Value
    Me.C6 = xApp.range("L132").Value
    Me.Totalpoints = xApp.range("H24").Value
    Me.Rate_Bygning = xApp.range("h32").Value
    Me.Rate_Driftstab = xApp.range("H30").Value
    Me.Rate_løsøre = xApp.range("H27").Value
    Me.RSnr = Nz(xApp.range("M4").Value, "Ubekendt RSnr")
    Me.RISKnavn = Nz(xApp.range("A2").Value, "Ubekendt Navn")
    Me.RISKAdr = Nz(xApp.range("A3").Value, "Ubekendt Adr")
    Me.Tarifdato = Nz(xApp.range("L2").Value, "Ubekendt Dato")
    Me.tarifVersion = Nz(xApp.range("F1").Value, "Ubekendt Tarifversion")
    xApp.ActiveWorkbook.Close savechanges:=False
End Sub

Første modul giver følgende fejl :

Member already excists in an object module from wi´hich this object module derives

Hm den er lavet, så den køres fra en db og smider data i en anden db.
lav en tabel i en anden db og husk lige at sætte office referencen.
jeg bruger sådan et kald:


Sub test()
    FileSearch_EXCELL "C:\Documents and Settings\risthen\My Documents", True, "*.xls", "C:\Documents and Settings\xxx\My Documents\extractexcell.mdb", "tblfilnavn", "filnavn"
End Sub

tblfilnavn ser sådan ud:
filnavn, medtag, FDato, filsize

Ahhh ... der var vist lige oplysningerne om tblfilnavn jeg manglene :o)

Den stopper programkørslen ved  .FileType = msoFileTypeAllFiles

Du overså en vigtig linie i subben:

' Set Microsoft Office 9.0->11,0 Object Library before Executing this Sub

Her er en sturm til at løbe tabellen igennem og hente data ind via en move funktion, som de tilpasser efter ovestående.
Denne del er lavet i DAO men kan ændres til ADO
Sub hentdatafrafilnavn()
Dim db As DAO.Database
Dim RsFil As DAO.Recordset
'
Set db = CurrentDb
Set RsFil = db.OpenRecordset("tblfilnavn", dbOpenDynaset)
If Not (Err = 0) Then
    RsFil.Close
    Exit Sub
End If
Forms![inddata]![lblfilnavn].Caption = ""
Forms![inddata].Refresh
While Not RsFil.EOF
    'MsgBox Rsfil.Fields(0)
    Forms![inddata]![lblfilnavn].Caption = RsFil.Fields(0)
    Forms![inddata].Refresh
    Movedata RsFil.Fields(0), "Tblaktiv"
   
    RsFil.MoveNext
Wend
   
    Forms![inddata]![lblfilnavn].Caption = "Dataindsamlingen er Nu Slut"
    Forms![inddata].Refresh
    RsFil.Close ' luk skidtet
    Set RsFil = Nothing
    db.Close ' også her
    Set db = Nothing
    ' slut prut finale
End Sub

Nu bliver jeg forvirret på et højere plan :o(

Hvis jeg remmer .FileType = msoFileTypeAllFiles ud, kører modulet videre, blot bliver medtag, FDato, filsize ikke opdateret

Ok filsize var noget med talformat, men FDato hvilket format er det ?

Du skal gå ind i references og sætte referencen til

Microsoft Office 9.0 Object Library
Det kan godt være at du kører med 11.0 - det er ligemeget.
Den virker ikke førend at du laver denne reference

Fdato er et datofelt- hvis man ønsker datoen på filen.

Microsoft Office 9.0 Object Library har kørt hele tiden, så det er ikke der problemet er :o(

FDato bliver ikke opdateret, jeg har ikke luret endnu, hvor jeg henter det ud at modulet. Det svarer til denne kodestump:

rs.Fields("filnavn") = .FoundFiles(intI)
'rs.Fields("FDato") = .FoundFiles(intI).Date
rs.Fields("filsize") = FileLen(.FoundFiles(intI)) / (1024 ^ 2)

HM hvis jeg fjerner referencn til ofice objectet får jeg netop denne fejl. Hvis den afkrydses, kører det !!!

(hopper lige af, så jeg ikke får alle disse mails ;)

:o)

Jeg bliver nødt til at smutte til et møde, men jeg kan sende dig en funkende Access XP -> 97 udgave af rutinen til dig.

det må du meget gerne ( zipped ) til ose@post.dk ... foreløbig tak

Dette klarede dato-problemet

rs.Fields("FDato") = FileDateTime(.FoundFiles(intI))

Jeg har fundet ud af, at ikke alle har placeret regneark i den biblioteksstruktur som jeg har bedt dem om, men derimod i underbiblioteker også ...

Kan denne :

FileSearch_EXCELL "C:\Documents and Settings\risthen\My Documents", True, "*.xls", "C:\Documents and Settings\xxx\My Documents\extractexcell.mdb", "tblfilnavn", "filnavn"

defineres til at medtage alle *.xls filer i underlæggende biblioteker også ?

Ok ... tålmodighed er en dyd ... fandt selv løsningen på underbibliotekerne ;o)

Tilbage igen - kører det ellers!

Det kan den 'true' fisker også fra alle subdirectories.
Skal det være access 97, 2000, XP eller 2003
Jeg bliver nødt til at løbe om 20 min.

Jeg tror Thomas hjælper mig færdig i andet regi ... tak for din hjælp

OKIDOKI