AW: Keine Rückmeldung nach Zelleneintrag
04.06.2015 14:40:46
Berlin030
Hallo Selli,
im folgenden der komplette Code:
Option Explicit
'allgemeines Modul
Public Const strPW = "" 'Passwort für Blattschutz
Sub Monatsdaten_Uebertragen()
Dim wksErfassung As Worksheet, wksArchiv As Worksheet
Dim ZeileErf As Long, strName As String, strVorname As String
Dim datDatum As Date, strJahrMonat As String
Dim varGewicht As Variant
Dim StatusCalc As Long
Dim Zeile_Archiv As Long
datDatum = DateSerial(Year:=Year(Date), Month:=Month(Date) - 1, Day:=1)
strJahrMonat = Format(datDatum, "YYYY-MM")
If MsgBox("Daten für Monat """ & strJahrMonat & """ ins Archiv übertragen?", _
vbQuestion + vbOKCancel, "Erfassungdsdaten archivieren") = vbCancel Then Exit Sub
Set wksArchiv = Archiv
Set wksErfassung = Erfassung
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
wksArchiv.Unprotect Password:=strPW
With wksErfassung
For ZeileErf = 5 To .Cells(.Rows.Count, 2).End(xlUp).Row
'prüfen, ob Name eingetragen ist
If .Cells(ZeileErf, 2) "" Then
strName = .Cells(ZeileErf, 2).Text
strVorname = .Cells(ZeileErf, 3).Text
With .Cells(ZeileErf, 6)
If IsNumeric(.Text) Then
varGewicht = .Value
Else
varGewicht = vbEmpty '"#NV"
End If
End With
With wksArchiv
Zeile_Archiv = .Cells(.Rows.Count, 1).End(xlUp).Row
If IsEmpty(.Cells(Zeile_Archiv, 1)) Then
Else
Zeile_Archiv = Zeile_Archiv + 1
End If
With .Cells(Zeile_Archiv, 1)
.Value = strName
.Offset(0, 1) = strVorname
With .Offset(0, 2)
If vbEmpty = varGewicht Then
.ClearContents
Else
.Value = varGewicht
End If
End With
.Offset(0, 3) = datDatum
.Offset(0, 4) = "'" & strJahrMonat
.Offset(0, 5) = strName & ", " & strVorname
.Offset(0, 6) = strName & "|" & strVorname & "|" & strJahrMonat
End With
End With
End If
DoEvents
Next
'Datum der Archivierung eintragen
.Range("Y4") = Date
'nächsten Stichtag für Archivierung eintragen
.Range("Y3") = DateSerial(Year:=Year(datDatum), Month:=Month(datDatum) + 2, Day:=1)
End With
wksArchiv.Protect Password:=strPW, AllowFiltering:=True
With Worksheets("Pivot-Auswertung")
.Unprotect strPW
.PivotTables(1).RefreshTable
.Protect Password:=strPW, AllowUsingPivotTables:=True
End With
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub
'Zum Ändern des Passworts:
'1.: Makro "BlattSchutzAufheben" ausführen
'2.: Wert der Konstanten strPW oben in diesem Modul auf neues Passwort ändern
'3.: Makro "BlattSchutzAktivieren" ausführen
Private Sub BlattSchutzAufheben()
Dim objSh As Object
For Each objSh In ActiveWorkbook.Sheets
objSh.Unprotect Password:=strPW
Next
End Sub
Private Sub BlattSchutzAktivieren()
Dim objSh As Object
For Each objSh In ActiveWorkbook.Sheets
Select Case objSh.Name
Case "Pivot-Auswertung"
objSh.Protect Password:=strPW, AllowUsingPivotTables:=True
Case "Archiv"
objSh.Protect Password:=strPW, AllowFiltering:=True
Case Else
objSh.Protect Password:=strPW
End Select
Next
End Sub