Office: Makro funktioniert nur nach Datei öffnen

Hallo,

anbei ne Tabelle in der durch "Eingabe" B7 der Monat verändert werden kann.
Daten werden ein- und ausgelesen bei Änderung. Dies funzt allerdings nur nach dem öffnen der Datei. Wenn anderes Makro (Neue Woche oder Daten speichern) ausgeführt wird, funzt es nich mehr. Wo ist der Fehler???????

Wäre auch gut, wenn ein Monat ausgewählt wird der noch nicht unter "Alle_Wochen" erfasst wurde, ne Fehler-Meldung kommt "Monat nich da, anlegen ja nein"

Bin wie immer dankbar für jede Hilfe.

 

Hallo!

EnableEvents = False
darf erst nach der Zellabfrage (If Target.Address...) kommen.
Die Variable objEingabe brauchst du überhaupt nicht, da sich der Code ja im Modul dieses Blatts befindet.
Teste mal diese Korrektur, Verkürzung, Beschleunigung:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
'Verlasse den Code, wenn die geänderte Zelle nicht B7 ist:
If Target.Address <> "$B$7" Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim objDaten As Worksheet
Dim lngR As Long, intC As Integer, lngEingabe As Long
Set objDaten = Sheets("Alle_Wochen")

With objDaten
Set rngtest = .Columns(1).Find(Range("B7"))
If Not rngtest Is Nothing Then
    lngR = rngtest.Row
Else
    MsgBox "Dieses Datum existiert noch nicht!" & vbLf & "Es wird angelegt."
    .Range("A65536").End(xlUp).Offset(1, 0) = Range("B7")
    lngR = .Range("A65536").End(xlUp).Row + 1
End If
      For intC = 1 To 91
      Select Case intC
        Case 1 To 16 'Spalten 1 bis 16 (A bis P)
        'Daten in B2:B22 eintragen
        lngEingabe = 7 '1. Eingabezeile in Spalte B
        If Not Cells(lngEingabe + intC - 1, 2).HasFormula Then
           Cells(lngEingabe + intC - 1, 2).Value = .Cells(lngR, intC).Value
              End If
         Case 17 To 31 'Spalten 17 bis 31
        'Daten in C3:C22 eintragen
        lngEingabe = 8 '1. Eingabezeile in Spalte C
        If Not Cells(lngEingabe + intC - 17, 3).HasFormula Then
           Cells(lngEingabe + intC - 17, 3).Value = .Cells(lngR, intC).Value
              End If
        Case 32 To 46 'Spalten
        lngEingabe = 8 '1. Eingabezeile in Spalte D
        If Not Cells(lngEingabe + intC - 32, 4).HasFormula Then
           Cells(lngEingabe + intC - 32, 4).Value = .Cells(lngR, intC).Value
              End If
        Case 47 To 61 'Spalten
        lngEingabe = 8 '1. Eingabezeile in Spalte E
        If Not Cells(lngEingabe + intC - 47, 5).HasFormula Then
           Cells(lngEingabe + intC - 47, 5).Value = .Cells(lngR, intC).Value
              End If
        Case 62 To 76 'Spalten
        lngEingabe = 8 '1. Eingabezeile in Spalte F
        If Not Cells(lngEingabe + intC - 62, 6).HasFormula Then
           Cells(lngEingabe + intC - 62, 6).Value = .Cells(lngR, intC).Value
              End If
        Case 77 To 91 'Spalten
        lngEingabe = 8 '1. Eingabezeile in Spalte G
        If Not Cells(lngEingabe + intC - 77, 7).HasFormula Then
           Cells(lngEingabe + intC - 77, 7).Value = .Cells(lngR, intC).Value
        End If
      End Select
   Next
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  End Sub
Private Sub NeueWoche_Click()
Range("B7").Value = ""
Range("B9:B13").Value = 0
Range("B16:B22").Value = 0
Range("C9:G13").Value = ""
Range("C16:G22").Value = 0
'Range("C27").Value = 0
End Sub
Private Sub WocheSpeichern_Click()
    'SchutzAufheben ("abc123")
Dim objDaten As Worksheet
Dim rng As Range, rngF As Range, varSuchen As Variant
Dim lngN As Long, intC As Integer, lngEingabe As Long

Set objDaten = Worksheets("Alle_Wochen")  'Datentabelle

  With objDaten
    'Prüfen, ob Datum schon vorhanden
    varSuchen = Range("B7").Text
    Set rngF = .Columns(1).Find(what:=varSuchen, _
        LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
    'EinfügeZeile ermitteln
    If Not rngF Is Nothing Then
       lngN = rngF.Row
       If MsgBox("vorhandenen Daten für """ & Range("B7").Text _
          & """ überschreiben?", vbYesNo, "Daten Speichern") = vbNo Then
          Exit Sub
       End If
    Else
       lngN = Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Row + 1) 'erste freie Zeile in objDaten
    End If
    'Daten aus Eingabeblatt übertragen
    For intC = 1 To 91 'Spaltenzähler
       Select Case intC
         Case 1 To 16 'Spalten 1 bis 16 (A bis P)
           'Daten aus B2:B22 eintragen
           lngEingabe = 7 '1. Eingabezeile in Spalte B
           .Cells(lngN, intC).Value = Cells(lngEingabe + intC - 1, 2).Value
         Case 17 To 31 'Spalten 17 bis 31 (Q bis W)
           'Daten aus C3:C22 eintragen
           lngEingabe = 8 '1. Eingabezeile in Spalte D
           .Cells(lngN, intC).Value = Cells(lngEingabe + intC - 17, 3).Value
         Case 32 To 46 'Spalten
           'Daten aus D
           lngEingabe = 8 '1. Eingabezeile in Spalte D
           .Cells(lngN, intC).Value = Cells(lngEingabe + intC - 32, 4).Value
         Case 47 To 61 'Spalten
           'Daten aus E
           lngEingabe = 8 '1. Eingabezeile in Spalte E
           .Cells(lngN, intC).Value = Cells(lngEingabe + intC - 47, 5).Value
         Case 62 To 76 'Spalten
           'Daten aus F
           lngEingabe = 8 '1. Eingabezeile in Spalte F
           .Cells(lngN, intC).Value = Cells(lngEingabe + intC - 62, 6).Value
        Case 77 To 91 'Spalten
           'Daten aus F
           lngEingabe = 8 '1. Eingabezeile in Spalte G
           .Cells(lngN, intC).Value = Cells(lngEingabe + intC - 77, 7).Value
             
       End Select
    Next
    'Daten Sortieren
    lngN = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte Datenzeile
    .Range(.Rows(1), .Rows(lngN)).Sort _
            Key1:=.Range("A1"), _
            Order1:=xlAscending, _
            Header:=xlYes
    'Summenformel aktualisieren
    If .Cells(lngN, 1).Value = "Alle" Then
       For intC = 2 To 91
         .Cells(lngN, intC).FormulaR1C1 = "=SUM(R[" & (-lngN + 2) & "]C[0]:R[-1]C[0])"
       Next
    End If
  End With
   
Set objDaten = Nothing
Set rng = Nothing
Set rngF = Nothing
    
End Sub

 

Hallo Schatzi,

Du bist und bleibst ein Schatzi,

ja, es läuft nicht nur schneller sondern auch ruckelfrei! SUPER!!

daher lese ich fast jede Deiner Antworten im Forum, Du erläuterst auch in verständlicher Sprache (nicht wie F1 bei Excel).

Danke Dir herzlich, LG silex1

 

Hallo Schatzi,

hab gerade noch mal Daten eingetragen und rumgespielt.
Folgendes Problem:

Wenn ich die Datei geöfnet habe, kann ich mit "B7" supie arbeiten, auch das mit der Meldung (MsgBox) funktionert.
Leider geht dann nix mehr. Es werden immer wieder (auch bekannte Monate) neu angelegt.
Auch wenn ich innerhalb des bekannten Monats etwas ändere und speichere, kann ich dann nicht mehr mit "B7" arbeiten. Die Daten des bearbeiteten Monats bleiben stehen. Erst nach schließen und erneutem öffnen der Datei geht es wieder mit "B7".
Wenn man es weis, kann man so schon schön arbeiten. Es müssen aber auch andere damit arbeiten? Gibts da Abhilfe?

Hoffe, ich gehe Dir mit meinen 3 Gehirnzellen, nich so auf den Geist,

LG silex1

 

Hallo Schatzi,

hab gerade noch mal Daten eingetragen und rumgespielt.
Folgendes Problem:

Wenn ich die Datei geöfnet habe, kann ich mit "B7" supie arbeiten, auch das mit der Meldung (MsgBox) funktionert.
Leider geht dann nix mehr. Es werden immer wieder (auch bekannte Monate) neu angelegt.
Auch wenn ich innerhalb des bekannten Monats etwas ändere und speichere, kann ich dann nicht mehr mit "B7" arbeiten. Die Daten des bearbeiteten Monats bleiben stehen. Erst nach schließen und erneutem öffnen der Datei geht es wieder mit "B7".
Wenn man es weis, kann man so schon schön arbeiten. Es müssen aber auch andere damit arbeiten? Gibts da Abhilfe?

Hoffe, ich gehe Dir mit meinen 3 Gehirnzellen, nich so auf den Geist,

LG silex1

 

Hallo!

Sorry, keine Ahnung, was da los ist.
Ich habe das gleiche Problem, aber Abhilfe weiß ich leider auch nicht...

 

Hallo Schatzi,

des Problem lag hier:

With objDaten
Set rngtest = .Columns(1).Find(Range("B7"), LookIn:=xlFormulas)
'Set rngtest = .Columns(1).Find(Range("B7"))

jetzt funzt es Dank deiner riesigen Vorarbeit!
Danke Dir nochmal!!!!! Bleib uns und dem Forum lange erhalten!!!
lg silex1