Forbedring af langsom kode

Nu er jeg ikke helt ovenpå Excel vs. Access, men du ville muligvis kunne spare
noget ved at genbruge din database forbindelse.

Du opretter, bruger og lukker en ny forbindelse inden i en løkke, det må kunne gøres
anderledes.

Jeg lytter indtil videre bare med. :-)

Ja det lyder da rigtigt - en eller anden må vel kunne gøre det ;0)

Kig evt lidt på dette her eksempel:
http://www.exceltip.com/st/Import_data_from_Access_to_Excel_(ADO)_using_VBA_in_Microsoft_Excel/427.html

Prøv evt. med denne her.

----------------
Sub AntalLBesøg()
On Error Resume Next
   
    Dim rsData As ADODB.Recordset
    Dim szConnect As String
    Dim szSQL As String
    Dim sPath As String
    Dim Tlfno As String
    Dim Dato As Date, CRange As Range, C As Range, R As Range
   
    Set R = Array("C8:G13", "C18:G23", "C28:G33")
    Set CRange = ActiveWorkbook.Sheets("1. Kvartal").Range("Datoer")
   
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
       
    ' Opret forbindelse til DB
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source =" & sPath & "gps.mdb;"
    cn.Open szConnect
       
    ' Opret en Recordset
    Set rsData = New ADODB.Recordset
   
    For Each C In CRange
        If C.Interior.ColorIndex <> xlNone Then
            Dato = C.Value
            Tlfno = ActiveWorkbook.Sheets("1. Kvartal").Range("H2").Value
            sPath = ActiveWorkbook.Path & "\"
           
            szSQL = "SELECT * FROM LKalender WHERE Tlf = '" & Tlfno & "' AND Dato = '" & Dato & "' AND Tekst1 <> '""'"
           
            ' Åben en ny cursor på den eksisterende recordset
            rsData.Open szSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
             
            RecordCount = 0
            rsData.MoveFirst
           
            Do Until rsData.EOF
                RecordCount = RecordCount + 1
                rsData.MoveNext
         
                Count = (RecordCount / 2)
   
                If Count > 2 Then
                    C.Interior.ColorIndex = 3
                ElseIf Count > 0 And Count < 3 Then
                    C.Interior.ColorIndex = 6
                Else
                    C.Interior.ColorIndex = 4
                End If
            Loop
        End If
        rsData.Close
    Next C
   
    Set rsData = Nothing

End Sub

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

Rettelse:
' Åben en ny cursor på den eksisterende recordset

Til:
' Åben en ny cursor på resultatet af szSQL sætningen

Det giver en uoprettelig loop?

Ok, det kan være det var for drastisk at hive oprettelsen af recordset ud af løkken
Prøv med:

-----------
Sub AntalLBesøg()
On Error Resume Next
   
    Dim szConnect As String
    Dim szSQL As String
    Dim sPath As String
    Dim Tlfno As String
    Dim Dato As Date, CRange As Range, C As Range, R As Range
   
    Set R = Array("C8:G13", "C18:G23", "C28:G33")
    Set CRange = ActiveWorkbook.Sheets("1. Kvartal").Range("Datoer")
   
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
       
    ' Opret forbindelse til DB
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source =" & sPath & "gps.mdb;"
    cn.Open szConnect
       
    ' Opret en Recordset
    Dim rsData As ADODB.Recordset
   
    For Each C In CRange
        If C.Interior.ColorIndex <> xlNone Then
            Dato = C.Value
            Tlfno = ActiveWorkbook.Sheets("1. Kvartal").Range("H2").Value
            sPath = ActiveWorkbook.Path & "\"
           
            szSQL = "SELECT * FROM LKalender WHERE Tlf = '" & Tlfno & "' AND Dato = '" & Dato & "' AND Tekst1 <> '""'"
           
            ' Åben en ny cursor på resultatet af szSQL sætningen
            Set rsData = New ADODB.Recordset
            rsData.Open szSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
             
            RecordCount = 0
            rsData.MoveFirst
           
            Do Until rsData.EOF
                RecordCount = RecordCount + 1
                rsData.MoveNext
         
                Count = (RecordCount / 2)
   
                If Count > 2 Then
                    C.Interior.ColorIndex = 3
                ElseIf Count > 0 And Count < 3 Then
                    C.Interior.ColorIndex = 6
                Else
                    C.Interior.ColorIndex = 4
                End If
            Loop
        End If
       
        ' Luk cursoren
        rsData.Close
        Set rsData = Nothing
    Next C
End Sub
---------------------

Tilsvarende løkke men nu ikke uoprettelig - fejl ved End if under C.Interior.Colorindex = 4

Prøv at erstatte den sidste del med:

---------
          Do Until rsData.EOF
                RecordCount = RecordCount + 1
                rsData.MoveNext
         
                Count = (RecordCount / 2)
   
                If Count > 2 Then
                    C.Interior.ColorIndex = 3
                ElseIf Count > 0 And Count < 3 Then
                    C.Interior.ColorIndex = 6
                Else
                    C.Interior.ColorIndex = 4
                End If
            Loop
           
            ' Luk cursoren
            rsData.Close
            Set rsData = Nothing
           
        End If
    Next C
   
    ' Luk DB forbindelse
    cn.Close
    Set cn = Nothing
   
End Sub

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

Hvad mener du med uoprettelig ?

Jeg var nødt til at lave ctrl+alt+del for at stoppe og herefter genstarte excel

Prøv evt med denne her:
Jeg opdagede lige at sPath først bliver sat inden i løkken, hvis vi skal oprette forbindelsen udenfor løkken skal sPath følge med ud...

---------------
Sub AntalLBesøg()

On Error Resume Next
    Dim rsData As ADODB.Recordset
    Dim szConnect As String
    Dim szSQL As String
    Dim sPath As String
    Dim Tlfno As String
    Dim Dato As Date, CRange As Range, C As Range, R As Range
   
    Set R = Array("C8:G13", "C18:G23", "C28:G33")
    Set CRange = ActiveWorkbook.Sheets("1. Kvartal").Range("Datoer")
   
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
       
    sPath = ActiveWorkbook.Path & "\"
       
    ' Opret forbindelse til DB
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source =" & sPath & "gps.mdb;"
    cn.Open szConnect
   
    For Each C In CRange
        If C.Interior.ColorIndex <> xlNone Then
       
                Dato = C.Value
                Tlfno = ActiveWorkbook.Sheets("1. Kvartal").Range("H2").Value

                szSQL = "SELECT * FROM LKalender WHERE Tlf = '" & Tlfno & "' AND Dato = '" & Dato & "' AND Tekst1 <> '""'"
               
                Set rsData = New ADODB.Recordset
                rsData.Open szSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
               
                RecordCount = 0
                rsData.MoveFirst
                Do Until rsData.EOF
                RecordCount = RecordCount + 1
                rsData.MoveNext
               
                Count = (RecordCount / 2)
         
                If Count > 2 Then
                    C.Interior.ColorIndex = 3
                ElseIf Count > 0 And Count < 3 Then
                    C.Interior.ColorIndex = 6
                Else
                    C.Interior.ColorIndex = 4
                End If
                Loop
           
                Set rsData = Nothing
        End If
    Next C

End Sub

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

Så er den der. Det var dejligt . Svar så får du point.
Egentlig burde det være unødvendigt at køre hele det loop der tæller records idet blot én dato anvendes for hver C. Kan du se en måde dette kan løses på?

For en god ordens skyld må vi hellere tilføje

-------
    ' Luk DB forbindelse
    cn.Close
    Set cn = Nothing
   
End Sub
-----------------

...til sidst

Dvs. for hver celle i CRange er der en tilhørende unik dato.
Så tæller du antal hits på den dato, og farver cellerne derefter ?

Præcis det er sådan den bør fungere!

Hvis du kun ønsker et antal hits, kan du ændre SQL sætningen til:
szSQL = "SELECT COUNT(*) FROM LKalender WHERE Tlf = '" & Tlfno & "' AND Dato = '" & Dato & "' AND Tekst1 <> '""'"

I det tilfælde skal der så tilføjes lidt ekstra kode for at få fat i den returnerede værdi. Du vil så slippe for selv at skulle tælle resultatrækkerne op.

Det ser da godt ud men hvordan får jeg så fat i værdien?

Vi kan lige lave et lille eksperiment med.

Hvis det virker efter hensigten vil du se en MessageBox med det korrekte antal for den pågældende dato.

---------
Sub AntalLBesøg()
On Error Resume Next
   
    Dim szConnect As String
    Dim szSQL As String
    Dim sPath As String
    Dim Tlfno As String
    Dim Dato As Date, CRange As Range, C As Range, R As Range
   
    Set R = Array("C8:G13", "C18:G23", "C28:G33")
    Set CRange = ActiveWorkbook.Sheets("1. Kvartal").Range("Datoer")
   
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
       
    ' Opret forbindelse til DB
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source =" & sPath & "gps.mdb;"
    cn.Open szConnect
       
    ' Opret en Recordset
    Dim rsData As ADODB.Recordset
   
    ' Opret en Recordset Field
    Dim fld As ADODB.Field
   
    For Each C In CRange
        If C.Interior.ColorIndex <> xlNone Then
            Dato = C.Value
            Tlfno = ActiveWorkbook.Sheets("1. Kvartal").Range("H2").Value
            sPath = ActiveWorkbook.Path & "\"
           
            szSQL = "SELECT * FROM LKalender WHERE Tlf = '" & Tlfno & "' AND Dato = '" & Dato & "' AND Tekst1 <> '""'"
           
            ' Åben en ny cursor på resultatet af szSQL sætningen
            Set rsData = New ADODB.Recordset
            rsData.Open szSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
           
            Set fld = rsData.Fields.Item(ix)
           
          MsgBox C.Value & " : " & fld.Value
             
            RecordCount = 0
            rsData.MoveFirst
           
            Do Until rsData.EOF
                RecordCount = RecordCount + 1
                rsData.MoveNext
         
                Count = (RecordCount / 2)
   
                If Count > 2 Then
                    C.Interior.ColorIndex = 3
                ElseIf Count > 0 And Count < 3 Then
                    C.Interior.ColorIndex = 6
                Else
                    C.Interior.ColorIndex = 4
                End If
            Loop
           
            ' Luk cursoren
            rsData.Close
            Set rsData = Nothing
           
        End If
    Next C
   
    ' Luk DB forbindelse
    cn.Close
    Set cn = Nothing
   
End Sub

----------

rettelse:
Set fld = rsData.Fields.Item(ix)

til:
Set fld = rsData.Fields.Item(0)

Så er vi tilbage til fejl ved: end if :0(

Efter rettelsen nåede den kun til:
Recordcount = Recordcount 0 + 1

Version med rettelsen:
---------
Sub AntalLBesøg()
On Error Resume Next
   
    Dim szConnect As String
    Dim szSQL As String
    Dim sPath As String
    Dim Tlfno As String
    Dim Dato As Date, CRange As Range, C As Range, R As Range
   
    Set R = Array("C8:G13", "C18:G23", "C28:G33")
    Set CRange = ActiveWorkbook.Sheets("1. Kvartal").Range("Datoer")
   
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
       
    ' Opret forbindelse til DB
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source =" & sPath & "gps.mdb;"
    cn.Open szConnect
       
    ' Opret en Recordset
    Dim rsData As ADODB.Recordset
   
    ' Opret en Recordset Field
    Dim fld As ADODB.Field
   
    For Each C In CRange
        If C.Interior.ColorIndex <> xlNone Then
            Dato = C.Value
            Tlfno = ActiveWorkbook.Sheets("1. Kvartal").Range("H2").Value
            sPath = ActiveWorkbook.Path & "\"
           
            szSQL = "SELECT COUNT(*) FROM LKalender WHERE Tlf = '" & Tlfno & "' AND Dato = '" & Dato & "' AND Tekst1 <> '""'"
           
            ' Åben en ny cursor på resultatet af szSQL sætningen
            Set rsData = New ADODB.Recordset
            rsData.Open szSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
           
            Set fld = rsData.Fields.Item(0)
           
            MsgBox C.Value & " : " & fld.Value
             
            RecordCount = 0
            rsData.MoveFirst
           
            Do Until rsData.EOF
                RecordCount = RecordCount + 1
                rsData.MoveNext
         
                Count = (RecordCount / 2)
   
                If Count > 2 Then
                    C.Interior.ColorIndex = 3
                ElseIf Count > 0 And Count < 3 Then
                    C.Interior.ColorIndex = 6
                Else
                    C.Interior.ColorIndex = 4
                End If
            Loop
           
            ' Luk cursoren
            rsData.Close
            Set rsData = Nothing
            Set fld = Nothing
           
        End If
    Next C
   
    ' Luk DB forbindelse
    cn.Close
    Set cn = Nothing
   
End Sub

----------

Fejl ved: End if

OK, prøv:

-----------
Sub AntalLBesøg()
On Error Resume Next
   
    Dim szConnect As String
    Dim szSQL As String
    Dim sPath As String
    Dim Tlfno As String
    Dim Dato As Date, CRange As Range, C As Range, R As Range
   
    Set R = Array("C8:G13", "C18:G23", "C28:G33")
    Set CRange = ActiveWorkbook.Sheets("1. Kvartal").Range("Datoer")
   
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
       
    ' Opret forbindelse til DB
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source =" & sPath & "gps.mdb;"
    cn.Open szConnect
       
    ' Opret en Recordset
    Dim rsData As ADODB.Recordset
   
    ' Opret en Recordset Field
    Dim fld As ADODB.Field
   
    For Each C In CRange
        If C.Interior.ColorIndex <> xlNone Then
            Dato = C.Value
            Tlfno = ActiveWorkbook.Sheets("1. Kvartal").Range("H2").Value
            sPath = ActiveWorkbook.Path & "\"
           
            szSQL = "SELECT COUNT(*) FROM LKalender WHERE Tlf = '" & Tlfno & "' AND Dato = '" & Dato & "' AND Tekst1 <> '""'"
           
            ' Åben en ny cursor på resultatet af szSQL sætningen
            Set rsData = New ADODB.Recordset
            rsData.Open szSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
           
            Set fld = rsData.Fields.Item(0)
           
            'MsgBox C.Value & " : " & fld.Value
       
            With fld
                If .Value > 2 Then
                    C.Interior.ColorIndex = 3
                ElseIf .Value > 0 And .Value < 3 Then
                    C.Interior.ColorIndex = 6
                Else
                    C.Interior.ColorIndex = 4
                End If
            End With
           
            ' Luk cursoren
            rsData.Close
            Set rsData = Nothing
            Set fld = Nothing
           
        End If
    Next C
   
    ' Luk DB forbindelse
    cn.Close
    Set cn = Nothing
   
End Sub

---------

Nu hvor jeg får tænkt mig om skal den kode der fungerede kaldes fra Worksheet_Activate. Den kode jeg skal kalde fra Worksheet_Change skal blot indholde en datoværdi: Range("O6").
Undskyld forvirringen :0(

2 sek..

Jeg smed lige en forkert version på...

Sub AntalLBesøg()
On Error Resume Next
   
    Dim szConnect As String
    Dim szSQL As String
    Dim sPath As String
    Dim Tlfno As String
    Dim Dato As Date, CRange As Range, C As Range, R As Range
   
    Set R = Array("C8:G13", "C18:G23", "C28:G33")
    Set CRange = ActiveWorkbook.Sheets("1. Kvartal").Range("Datoer")
   
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
       
    sPath = ActiveWorkbook.Path & "\"
   
    ' Opret forbindelse til DB
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source =" & sPath & "gps.mdb;"
    cn.Open szConnect
       
    ' Opret en Recordset
    Dim rsData As ADODB.Recordset
   
    ' Opret en Recordset Field
    Dim fld As ADODB.Field
   
    For Each C In CRange
        If C.Interior.ColorIndex <> xlNone Then
            Dato = C.Value
            Tlfno = ActiveWorkbook.Sheets("1. Kvartal").Range("H2").Value
           
            szSQL = "SELECT COUNT(*) FROM LKalender WHERE Tlf = '" & Tlfno & "' AND Dato = '" & Dato & "' AND Tekst1 <> '""'"
           
            ' Åben en ny cursor på resultatet af szSQL sætningen
            Set rsData = New ADODB.Recordset
            rsData.Open szSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
           
            Set fld = rsData.Fields.Item(0)
           
            'MsgBox C.Value & " : " & fld.Value
       
            With fld
                If .Value > 2 Then
                    C.Interior.ColorIndex = 3
                ElseIf .Value > 0 And .Value < 3 Then
                    C.Interior.ColorIndex = 6
                Else
                    C.Interior.ColorIndex = 4
                End If
            End With
           
            ' Luk cursoren
            rsData.Close
            Set rsData = Nothing
            Set fld = Nothing
           
        End If
    Next C
   
    ' Luk DB forbindelse
    cn.Close
    Set cn = Nothing
   
End Sub

ok, dvs. datoen kan altid hentes fra O6 ?

Ja i koden der skal aktiveres når der kommer ændringer i arket. Men den kode jeg skrev fungerede som fungerede godt skal kaldes ved aktivering af akret således at alle månedens datoer bliver farvelagt afhængig af Count.
Bortset fra det fungerer den sidste kode OGSÅ og er rimelig hurtig.
Men mon ikke det alligevel er bedst at anvende 2 forskellige koder af hensyn til hastigheden når databasen bliver større?

Ups - jeg staver nærmest som en analfabet

WS_Activate versionen skal ihvertfald hente en række datoer vha. løkken.
WS_Change kan så bare nøjes med en simpel DB forespørgsel uden en løkke.

Det vil nok være bedst at lave to versioner

Nemlig

Den seneste jeg smed op kan vel bruges som WS_Activate versionen, med flere datoer.

Indtil nu har jeg anvendt samme kode og det må være uhensigtsmæssigt

Ja den sidste kode fungerede rigtig godt

Bruger du range variablen 'R' til noget som helst ?

Nej den er en fejl

Jeg skal lige være helt sikker... :-)

Er det kun feltet i kalenderen der svarer til datoen i O6 der skal opdateres ?
Dvs. kun én celle ?

...i WS_Change versionen ?

O6 repræsenterer en dato i en dag-kalender. Dagkalenderen viser ved at hø-klikke på datoen i en månedskalender. Det er i dagkalenderen at teksten bliver indført men i månedskalenderen at farveændringerne sker.

ok, prøv med:


----------
'''''''''''''''''''''
' WS CHANGE version
'''''''''''''''''''''

Sub AntalLBesøg()
On Error Resume Next
   
    Dim szConnect As String
    Dim szSQL As String
    Dim sPath As String
    Dim Tlfno As String
    Dim Dato As Date
    CRange As Range
    C As Range

    Set CRange = ActiveWorkbook.Sheets("1. Kvartal").Range("Datoer")
   
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
       
    sPath = ActiveWorkbook.Path & "\"
    ' Opret forbindelse til DB
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source =" & sPath & "gps.mdb;"
    cn.Open szConnect
       
    ' Opret en Recordset
    Dim rsData As ADODB.Recordset
   
    ' Opret en Recordset Field
    Dim fld As ADODB.Field
   
    Set Dato = [O6]
   
    For Each C In CRange
        If C.Value = Dato And C.Interior.ColorIndex <> xlNone Then
            Tlfno = ActiveWorkbook.Sheets("1. Kvartal").Range("H2").Value
           
            szSQL = "SELECT COUNT(*) FROM LKalender WHERE Tlf = '" & Tlfno & "' AND Dato = '" & Dato & "' AND Tekst1 <> '""'"
           
            ' Åben en ny cursor på resultatet af szSQL sætningen
            Set rsData = New ADODB.Recordset
            rsData.Open szSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
           
            Set fld = rsData.Fields.Item(0)
           
            With fld
                If .Value > 2 Then
                    C.Interior.ColorIndex = 3
                ElseIf .Value > 0 And .Value < 3 Then
                    C.Interior.ColorIndex = 6
                Else
                    C.Interior.ColorIndex = 4
                End If
            End With
           
            ' Luk cursoren
            rsData.Close
            Set rsData = Nothing
            Set fld = Nothing
           
        End If
    Next C
   
    ' Luk DB forbindelse
    cn.Close
    Set cn = Nothing
   
End Sub
----------

Den laver en compile error: Statement invalid outside type block og fejler ved CRAnge as Range

Nå selvfølgelig

Der mangler lige nogle 'Dim' foran CRange og C, sorry...

Efter første mindre rettelse fejler den ved Dato = [O6]:  Object required

Prøv med:
Set Dato = ActiveWorkbook.Sheets("1. Kvartal").Range("O6").Value

istedet for..
Hvis det er den sheet den ligger på.

Rettelse, der skal ikke bruges 'Set'...
Der skal stå:
Set Dato = ActiveWorkbook.Sheets("1. Kvartal").Range("O6").Value

Dato = ActiveWorkbook.Sheets("1. Kvartal").Range("O6").Value

Det er de der hurtige klippe-klistre fejl...

Jeg fejlede på samme måde igen men kørte efter at jeg fjernede: Set.
Det var dejligt - tak for det. Jeg har endnu et tillægsspørgsmål hvis du da ikke er på vej i seng: Jeg kan af en eller anden grund ikke slette Felterne i Dagkalenderen med Delete-knappen (de forbliver i access) mens det går fint ved at anbringe sig i feltet og så anvende pil-til højre?

Hvad har du af kode tilknyttet din delete knap ?
Er det en knap der ligger på dit Excel ark ?

Nej den kaldes fra Worksheet_Change:

Sub UpdateLKalender()


On Error Resume Next
    Dim rsData As ADODB.Recordset
    Dim szConnect As String
    Dim szSQL As String
    Dim sPath As String
    Dim Tlfno As String
    Tekst = ActiveCell.Offset(-1, 0).Text
    Tlfno = ActiveWorkbook.Sheets("1. Kvartal").Range("R2").Value
    Dato = ActiveWorkbook.Sheets("1. Kvartal").Range("O6").Value
    Tid = Format(ActiveCell.Offset(-1, -1).Value, "hh:mm")
   
    sPath = ActiveWorkbook.Path & "\"
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source =" & sPath & "gps.mdb;"
   
    If Tekst <> "" Then
        szSQL = "UPDATE LKalender SET Tekst1 = ('" & Tekst & "') WHERE Tlf = ('" & Tlfno & "') AND Dato=('" & Dato & "') AND Tid =('" & Tid & "')"
       
        Set rsData = New ADODB.Recordset
        rsData.Open szSQL, szConnect, , adLockOptimistic, adCmdText
       
        Set rsData = Nothing
   
    Else
      szSQL = "DELETE FROM LKalender WHERE LKalender.Tlf = ('" & Tlfno & "') And LKalender.Dato = ('" & Dato & "') And LKalender.Tid = ('" & Tid & "')"
   
   
      Set rsData = New ADODB.Recordset
        rsData.Open szSQL, szConnect, , adCmdText
   
      Set rsData = Nothing
    End If

End Sub

Nu har jeg ikke så meget erfaring med Access i Excel. Plejer man at kunne slette data i databasen ved at trykke på DELETE knappen ?
Jeg tror ikke det kan lade sig gøre.

Jeg går ud fra du mener keyboard-tasten DELETE og ikke en knap som du selv har placeret på arket.

Men selvfølgelig, så burde en sletning af en celles data udløse WS_Change makroen.

Ja jeg mener Keyboard-tasten. Men ovenstående kode der kører når teksten ændres burde vel kunne slette posten når tekst-feltet er tomt?

Umiddelbart kan jeg ikke se noget galt i Update funktionen.
Det skulle lige være at du i den ene del af IF sætningen skriver
      WHERE Tlf = ('" & Tlfno & "')
og i den anden del
      WHERE LKalender.Tlf = ('" & Tlfno & "')

Men det burde ikke have noget at sige

Nej jeg forstår det heller ikke og den lille fejl var et forsøg på at få den til at fungerer. I stedet har jeg nu inaktiveret delete-knappen. Men det er lidt utilfredsstillende at man ikke kan anvende den dertil anvendelige knap

Nå men det behøver du bestemt ikke bruge mere tid på - nu har jeg forsøgt i de sidste 2 dage at får det til at makke ret (uden en tilfredsstillende løsning).
Men igen tak for dit store arbejde. Jeg må sige at du er en ualmindelig hurtig programmør :0)

...og så vil jeg jo gerne af med de point!

Du får et svar så. :-)

Men, det lille DELETE problem vil nok irritere mig tilstrækkeligt til at jeg må grave lidt mere i sagen imorgen...

svar.

Du skal være så velkommen :0)

Jeg tror jeg har en løsning på DELETE problemet.

Der skal tilføjes følgende kode til samme modul som du har din Worksheet_Change kode i.

----------------------------
Dim twice As Boolean

Private Sub Worksheet_Activate()
    Application.OnKey "{DELETE}", "'ActiveWorkbook.Sheets(""1. Kvartal"").Worksheet_Change ActiveCell'"
    twice = False
End Sub

Private Sub Worksheet_Deactivate()
    ' Sørg for at DELETE opfører sig som den plejer
    ' efter du forlader fanebladet
    Application.OnKey "{DELETE}", ""
End Sub

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

Din Worksheet_Change kode skal se sådan ud:

-----------------
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim CRange As Range
    Dim isect As Range
   
    If Not twice Then
        Set CRange = ActiveWorkbook.Sheets("1. Kvartal").Range("Datoer")
        Set isect = Intersect(Target, CRange)
   
        ' Ryd cellens indhold uanset om du er indenfor kalender området
        twice = True
        ActiveCell.Clear
   
        If Not isect Is Nothing Then
            ' Du er indenfor kalender området
            UpdateLKalender
        End If
    Else
        twice = False
    End If
   
   
End Sub

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

Hvis du kalder flere funktioner end UpdateLKalender kan du skrive dem efter
linien
    UpdateLKalender

Når du trykker DELETE:
Worksheet_Change checker nu om du befinder dig indefor kalender området. Hvis du gør så slettes den aktive celle og UpdateLKalender proceduren kaldes.
Hvis du er udenfor kalender området, slettes den aktive celle som DELETE plejer at gøre.

Lav evt. lige en backup, inden du prøver med den nye kode.

Jeg glemte at nævne at linien
  Dim twice As Boolean

skal placeres som første linie i kodemodulet, således at det bliver en global variabel.

Fantastisk hvis du virkelig har fundet en løsning. Der fremkommer desværre en fejlmeddelelse når jeg anvender delete: Makroen "Activeworkbook.Sheets("1. Kvartal").Worksheet_Change ActiveCell" blev ikke fundet.

...og lige en lille tilføjelse: Der fremkommer også en error ved linien ActiveCell Clear (alle linier er flettede celler)

OK, jeg tror ideen er god nok, men der skal lige rettes nogle detaljer til.

Har du mulighed for at maile arket til mig ? (tc@elvis.dk)
Alternativt, hvis du kunne smide hele koden op fra det relevante kodemodul.

Jeg kigger på det igen iaften.

Prøv med:

---------
Private Sub Worksheet_Activate()
    Application.OnKey "{DELETE}", "'Worksheet_Change ActiveCell'"
    twice = False
End Sub
---------

istedet for.
Hvis ikke det virker, må jeg lige finde på noget andet :-)