Makro til at gemme udvalgte værdier fra Excel i Access

Hvordan udvælges værdier fra dine ark?
Det er ikke et større problem, at skrive en makro, der kan overføre værdier fra alle 20 ark til en tabel i en DB.

Hvordan skal tabellen i Access se ud?

Det med de 20 ark var bare for at beskrive problemet.. Makroen skal kun koncentrere sig om værdier fra det pågældende ark man har åbent (Og hvori makroen befinder sig).

Cellerne, der indeholder værdierne, er i forvejen kendte. Dvs at de aldrig ændrer plads.

Derfor kunne man for enkeltheds skyld antage at makroen skal hente værdier fra

Ark1!C7
Ark2!G8
Ark3!H10

Disse værdier skal så bare gemmes i en allerede oprettet access tabel (f.eks. tabel1), som kunne se ud på følgende måde:

ID(autonumerering), Tidspunkt(Dato og klokkelset), C (Tal), G (Tal), H (Tal);

Så jeg er ikke så meget interesseret i en komplet løsning, bare et lille eksempel på hvordan det gøres, da makroen skal tage højde for flere forskellige ting.

Jeg er ikke kun interesseret i at skrive til tabgellen, men også at læse fra den.

Eksempel: Makroen skal tjekke om Tidspunkt er dags dato. Hvis tidspunkt er dagsdato, så skal der ikke skrives til tabellen, fordi så er der allerede blevet skrevet i tabellen tidligere idag.

Skriv endelig, hvis der er noget du er i tvivl om!

Her er lidt at se på - til inspiration:

Rem Reference til MicrosoftDAO 6.0 Object Library (Alt+F11 / Tools / References...
Rem ==============================================================================
Rem Koden indsættes i ThisWorkbook

Dim xSti, db, tabel
Dim ArkTabel As Variant, antalElementer
Sub workbook_activate()                            'XLS-filen åbnes
Dim log, f
    findSti
    åbnDB
    åbnTabel
    log = ""
   
Rem Vis værdier i DB
    With tabel
        For f = 1 To .RecordCount
            log = log + Format(.Fields(1), "dd-mm-yy") + _
            " " + .Fields(2).Name + " " + CStr(.Fields(2)) + _
            " " + .Fields(3).Name + " " + CStr(.Fields(3)) + _
            " " + .Fields(4).Name + " " + CStr(.Fields(4)) + vbCr
            .MoveNext
        Next f
    End With
   
    MsgBox (log)
    lukDB
End Sub
Sub Workbook_BeforeClose(Cancel As Boolean)        'XLS-filen lukkes
    findSti
    opsætArkTabel
    opdaterDB
   
    lukDB
End Sub
Private Sub findSti()
    xSti = ActiveWorkbook.Path
    If Right(xSti, 1) <> "\" Then
        xSti = xSti + "\"
    End If
End Sub
Private Sub opsætArkTabel()
Rem Ark..............0....1......2.....3            'pt kun een celle pr. ark
    ArkTabel = Array("", "C7", "G8", "H10")        'tabel for celler til opdatering
    antalElementer = 4
End Sub
Private Sub opdaterDB()
Dim f, a
    åbnDB
    åbnTabel
   
    With tabel
        For f = 1 To .RecordCount
Rem findes dags dato i dato-feltet (1)
            If Format(.Fields(1), "dd-mm-yy") = Format(Now, "dd-mm-yy") Then
                Exit Sub
            End If
            .MoveNext
        Next f
       
Rem hvis dags dato ikke findes - så opdater
        .AddNew
        .Fields(1) = Now
       
Rem traverser gennem tabel - find ark/celleadresse og overfør til felter - startende med felt nr. 2
        For a = 0 To antalElementer - 1
            If ArkTabel(a) <> "" Then
                .Fields(2 + a - 1) = ActiveWorkbook.Sheets(a).Range(ArkTabel(a))
            End If
        Next a
        .Update
    End With
End Sub
Rem === DB-funktioner ===
Private Sub åbnDB()
    Set db = OpenDatabase(xSti + "Log.mdb")
End Sub
Private Sub åbnTabel()
    Set tabel = db.openrecordset("Tabel1")
End Sub
Private Sub lukDB()
    tabel.Close
    db.Close
End Sub

Hej.. Det ser godt ud.. Jeg kan ikke proeve det foer paa tirsdag, dajeg foerst moeder ind igen paa arbejde..

Haaber du vil tjekke ind igen tirs til torsdag, hvis jeg har nogle sporgsmaal!

Mange tak indtil videre!

Ok & selv tak...

Hejsa..

Så har jeg været ved at lege med det.. Jeg har ændret nogle få ting, men jeg har et problem..

Dim xSti, db, tabel
Dim ArkBGCeller As Variant, antalElementer
Dim ArkArk As Variant


Sub workbook_activate()                            'XLS-filen åbnes
Dim log, f
    findSti
    åbnDB
    åbnTabel
    log = ""
   
Rem Vis værdier i DB
    With tabel
        For f = 1 To .RecordCount
            log = log + Format(.Fields(1), "dd-mm-yy") + _
            " " + .Fields(2).Name + " " + CStr(.Fields(2)) + _
            " " + .Fields(3).Name + " " + CStr(.Fields(3)) + _
            " " + .Fields(4).Name + " " + CStr(.Fields(4)) + vbCr
            .MoveNext
        Next f
    End With
   
    MsgBox (log)
    lukDB
End Sub
Sub Workbook_BeforeClose()        'XLS-filen lukkes
   
   
    findSti
    opsætArkTabel
    opdaterDB
   
    lukDB
End Sub
Private Sub findSti()
    xSti = "G:\Afdelingen internt\AKTIER\Kvant\DaraCORE"
    If Right(xSti, 1) <> "\" Then
        xSti = xSti + "\"
    End If
End Sub
Private Sub opsætArkTabel()
Rem Ark..............0....1......2.....3            'pt kun een celle pr. ark
      firma = "Carlsberg"
      MsgBox (firma)
      ArkBGCeller = Array("", firma, "C7", "D7", "E7", "F7", "G7", "H7", "I7", "J7", "K7", "L7", "M7", "N7", "O7", "P7", "Q7", "R7")
     
     
    antalElementer = 18
   
End Sub
Private Sub opdaterDB()
Dim f, a
    åbnDB
    åbnTabel
   
    With tabel
        For f = 1 To .RecordCount
Rem findes dags dato i dato-feltet (1)
            If Format(.Fields(1), "dd-mm-yy") = Format(Now, "dd-mm-yy") And .Fields(2) = "Carlsberg" Then
                Exit Sub
            End If
            .MoveNext
        Next f
       
Rem hvis dags dato ikke findes - så opdater
        .AddNew
        .Fields(1) = Now
        .Fields(2) = firma
       
Rem traverser gennem tabel - find ark/celleadresse og overfør til felter - startende med felt nr. 2
     
            For a = 0 To antalElementer
            If ArkBGCeller(a) <> "" And ArkBGCeller(a) <> "Carlsberg" Then
                .Fields(2 + a - 1) = ActiveWorkbook.Sheets("Beregningsgrundlag").Range(ArkBGCeller(a))
            End If
            Next a
           
     
      Rem For a = 0 To antalElementer - 1
          Rem  If ArkTabel(a) <> "" Then
            Rem  .Fields(2 + a - 1) = ActiveWorkbook.Sheets(a).Range(ArkTabel(a))
          Rem  End If
        Rem Next a
        .Update
    End With
End Sub
Rem === DB-funktioner ===
Private Sub åbnDB()
    Set db = OpenDatabase(xSti + "DataCORE.mdb")
End Sub
Private Sub åbnTabel()
    Set tabel = db.openrecordset("Data_Yearly1")
End Sub
Private Sub lukDB()
    tabel.Close
    db.Close
End Sub


Under opdater DB(), hvor:

.Fields(2 + a - 1) = ActiveWorkbook.Sheets("Beregningsgrundlag").Range(ArkBGCeller(a))

Når a når til 2, dvs at ovenstående kode køres, så får jeg en subscript out of range fejl. Under debug er a = 2 og ArkBGCeller(a)="C7".

Linien virker fint, hvis jeg istedet indsætter "C7" istedet for ArkBGCeller(a).

Men så får jeg jo bare den samme værdi igennem hele databasen..

Ved du hvad problemet er?

Iøvrigt har jeg ikke Microsoft DAO 6, men kun DAO 3,6.. Hvad bliver den lige brugt til?

Ser på det - tror ikke at det er noget større problem.
Det skulle være 3.6 (slåfejl). Anvendes i VBA, således at koden i Excel kan "snakke" med databasen.

ok.. Jeg har fået det til at virke.. Lukkede lortet ned og startede op igen, og så virkede det!

Mange tak for din hjælp.. Det virker perfekt, og ikke mindst går det helt vildt hurtigt!.. Skal ca. gemme 500 tal og det sker med et millisekung.. Noget anderledes end med PULL funktionen mellem to excel ark.. Det ville nok have taget 20 minutter.

Skynd dig at smide et svar..

P.s. Hvordan ville man gøre, hvis man istedet vil opdatere den sidst skrevne linie, hvis den er dags dato, istedet for at stoppe løkken?

ok - her smides et svar!
Vender tilbage med dit P.s!

Så skal du åbne tabellen
- traversere gennem posterne og sammenligne feltet dato med dagsdato
- med posten
  .Edit (i stedet for AddNew)
  ...
  ...
  .Update

ok super.. tak for det!