Hent data fra Excel

Det er ikke lige til højre-benet men jeg har noget programkode som indlæser filnavnene i en tabel, og benytter sig af en løkke-rutine til at aflæse filnavn et efter et og importere afgrænsede data i regnearkene

Jo, tak....  men som du siger, den er ikke lige til højrebenet....

Sorry ... netværket strejkede

Denne programstump indlæser dine filnavne i en tabel i Access ( tblFilnavn )

Public Sub FileSearch_EXCELL(soegmappe As String, 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 = True
    '.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("FDato") = FileDateTime(.FoundFiles(intI))
            rs.Fields("filsize") = FileLen(.FoundFiles(intI)) '/ (1024 ^ 2)
            rs.Update ' gem 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

Aktiveres vha denne makro :

Private Sub IndlaesData_Click()
Dim strSQL As String
Dim db As DAO.Database

    Set db = CurrentDb()
   
    strSQL = "DELETE * FROM tblfilnavn"

        db.Execute strSQL
   
    'Udviklingsdrev
    FileSearch_EXCELL "C:\Data\Hotline udkørselskunder", "*.xls", "C:\Data\SamleDB.mdb", "tblfilnavn", "filnavn"
     
    'Udvekslingsdrev
    'FileSearch_EXCELL "X:\udveksling\Postservice\Udkørsler\Hotline udkørselskunder", "*.xls", "X:\udveksling\Postservice\Udkørsler\SamleDB.mdb", "tblfilnavn", "filnavn"
   
End Sub

Sorry der kom en programlinie for meget med

Private Sub IndlaesData1_Click()
Dim strSQL As String
Dim db As DAO.Database

    Set db = CurrentDb()
   
    strSQL = "DELETE * FROM tblfilnavn"

        db.Execute strSQL
   
    'Udviklingsdrev
    FileSearch_EXCELL "C:\Data\Hotline udkørselskunder", "*.xls", "C:\Data\SamleDB.mdb", "tblfilnavn", "filnavn"
     
   
End Sub

Hvis man nu har en tabel med et felt, hvordan ville man så få tallene fra f.eks. A1:C1 ind. Hvis vi får dette løst er der måske lys for enden af tunnelen!~)

Sidste argument bestemmer hvilket område du vil importere fra. Efterlades dette tomt, importerer du hele arket.

DoCmd.TransferSpreadsheet acExport, 8, "Tabel1", "D:\Mappe1", False, "A1:C1"

Store netværksproblemer har bevirket, at jeg ikke har kunnet følde denne tråd ... er I nået videre ???

Problemet er stadig:

Hvordan specificerer man arkets navn, får indlæst data i det rigtige felt i tabellen og indlæser mere end en dataserie!~)

Har du fået indlæst sti/filnavn i databasen ???

Her er et eksempel hvor jeg udtrækker kundedate fra Excel ( arkfane : Skabelon )

Skulle være rimeligt selvforklarende

Public Function AflæsfelterIExcel()
   
    Dim Xl As Object
    Dim rsKunde As New ADODB.Recordset
    Dim rsFiler As New ADODB.Recordset
    Dim cn As ADODB.Connection
   
    Set cn = CurrentProject.Connection
    Set Xl = CreateObject("EXCEL.APPLICATION")
   
    rsKunde.Open "tblKundeoplysninger", cn, adOpenKeyset, adLockOptimistic
    rsFiler.Open "tblFilnavn", cn, adOpenStatic
   
    Do Until rsFiler.EOF
        Xl.Workbooks.Open rsFiler!filnavn, False, True
        rsKunde.AddNew
        Xl.Sheets("Skabelon").SELECT
        rsKunde![Aftaledato] = Xl.Range("M1")
        rsKunde!Kundenummer = Xl.Range("A9")
        rsKunde!KundeNavn = Xl.Range("A3")
        rsKunde!Vejnavn = Xl.Range("A4")
        rsKunde!Husnummer = Xl.Range("C4")
        rsKunde!Postnummer = Xl.Range("A5")
        rsKunde!ByNavn = Xl.Range("B5")

        rsKunde.Update
        rsFiler.MoveNext

        Xl.Quit
        SendKeys "%{n}", True
               
        On Error Resume Next
                                     
    Loop

End Function

Jeg skal vist lige have en kop kaffe!~)

Kan du se systematikken i rsKunde og rsFiler ???

Ja, jeg prøver lige...

Ok, den sidste funktion kræver vel at man har indlæst sti/filnavne...
I så fald, hvordan skal tabellen til den indlæsning opbygges, for den beklager sig lidt ved feltet "filsize".

filsize er heller ikke obligatorisk ... programstumpen stammer fra en database, hvor jeg benytter filstørrelsen til at afgøre validiteten af de data jeg importerer

ok

Du kan bare remme den ud :o)

Ok, så langt så godt... Problemet er nu at det skal se nogenlunde sådan ud:

Public Function AflæsfelterIExcel()
   
    Dim Xl As Object
    Dim rsKunde As New ADODB.Recordset
    Dim rsFiler As New ADODB.Recordset
    Dim cn As ADODB.Connection
   
    Set cn = CurrentProject.Connection
    Set Xl = CreateObject("EXCEL.APPLICATION")
   
    rsKunde.Open "status", cn, adOpenKeyset, adLockOptimistic
    rsFiler.Open "tblFilnavn", cn, adOpenStatic
   
    Do Until rsFiler.EOF
        Xl.Workbooks.Open rsFiler!filnavn, False, True
        rsKunde.AddNew
        Xl.Sheets("Samlet").SELECT
        rsKunde![produkt] = Xl.range("B6:Q6")
        rsKunde!KgPrKar = Xl.range("B10:Q10")
        rsKunde!Vandprocent = Xl.range("B15:Q15")
        rsKunde!Uge = Xl.range("B1")

        rsKunde.Update
        rsFiler.MoveNext

        Xl.Quit
        SendKeys "%{n}", True
               
        On Error Resume Next
                                     
    Loop

End Function

Den stopper ved rsKunde![produkt] = Xl.range("B6:Q6") og siger typeuoverensstemmelse..

Nu skal du til at tænke over, hvorledes du vil have data i access, således at de er struktureret/normaliseret ...

Hvorledes havde du tænkt dig at et typist datasæt skal se ud i access ???

Produkt1; 1.032,50; 0,49
Produkt2; 1.211,03; 0,55

Jeg har ikke lige et id felt med, men det kan jeg jo lige gøre, så jeg kan få en primærnøgle!~)

Hov, jeg glemte uge:
Produkt1; 1.032,50; 0,49; 1
Produkt2; 1.211,03; 0,55; 1

Jeg tror du er nødt til at aflæse cellevis, dvs :

Do Until rsFiler.EOF
        Xl.Workbooks.Open rsFiler!filnavn, False, True
        rsKunde.AddNew
        Xl.Sheets("Samlet").SELECT

        rsKunde![produkt] = Xl.range("B6")
        rsKunde!KgPrKar = Xl.range("B10")
        rsKunde!Vandprocent = Xl.range("B15")
        rsKunde!Uge = Xl.range("B1")

        rsKunde![produkt] = Xl.range("C6")
        rsKunde!KgPrKar = Xl.range("C10")
        rsKunde!Vandprocent = Xl.range("C15")
        rsKunde!Uge = Xl.range("B1")

Ja, det er også det jeg er ved nu, så havde jeg lidt problemer med skalering af et decimaltal, men nu må vi se computeren arbejder!~)

Er det muligt at lave en løkke, som går fra B til Q

Det er sikkert muligt ... men så skal du benytte en løkke indeni en løkke ... ved ikke lige om det går helt godt ... under alle omstændigheder kræver det lidt programmering

Nu fik jeg data ind, jeg skal lige validere....

Der skulle indsættes ugenr i alle filer, men nu kører det!~)

Godt gået jensen....

Smid lige et svar og tak for hjælpen!~)

Velbekommen :o)

Tak for karma ;o)

Du har fortjent det!~)