überarbeitet!
21.01.2013 08:34:47
Klaus
Hi Jasper,
danke für die freundlichen Rückmeldungen!
Ich habe deine zwei Sonderwünsche noch eben eingebaut, ausserdem die kosmetischen Korrekturen aus meinem Thread weiter oben umgesetzt. Bei der Monat/Jahr MsgBox hab ichs mir einfach gemacht und den gesamten Code in eine "IF-MsgBox=Ja-Then" Schleife gepappt.
Option Explicit
Sub Makro1()
' Makro1 Makro
' Tastenkombination: Strg+Umschalt+X
HoleNamen
End Sub
Sub HoleNamen()
'### Holt eventuell fehlende Namen aus anderer Tabelle ins Archiv,
'### schreibt die entsprechenden Datümer zu den Namen
Dim lRowFirstName As Long
Dim lRowNameArchiv As Long
Dim iColNames As Integer
Dim iColDates As Integer
Dim wksData As Worksheet
Dim wksArchiv As Worksheet
'HIER musst du ein paar Sachen deklarieren, falls deine Mastertabelle abweicht
lRowFirstName = 7 'Namen stehen ab Zeile 7
iColNames = 5 'Namen stehen in Spalte 5 (=D)
iColDates = 4 'Datums stehen in Spalte 4 (=E)
lRowNameArchiv = 8 'im Archiv stehen die Namen in Zeile 8
Set wksData = Sheets("Seite2") 'Tabellenname Quelle
Set wksArchiv = Sheets("Archiv X") 'Tabellenname Archiv
'Prüfe ob Monat / Jahr korrekt. (MsgBox vbyesno = ja ergibt 6)
If MsgBox("Ist Bearbeitungsmonat Moant (sic!) " & wksArchiv.Range("A10").Value & " und Jahr " & _
wksArchiv.Range("B10").Value & " richtig?", vbYesNo) = 6 Then
'Anmerkung: eigentlich gehören alle DIMs nach oben. Ich hab hier unten weiter
'Dimensioniert, um den oberen (händisch zu ändernden) Codeteil etwas übersichtlicher zu _
lassen.
Dim rNames As Range
Dim lRowLastName As Long
Dim iColLast As Integer
Dim lRowLast
Dim bDoIt As Boolean
Dim sMissDate As String
Dim sMissName As String
Dim bShowMiss As Boolean
sMissDate = "Da fehlt ein Datum!" & Chr(10)
sMissName = "Da fehlt ein Name!" & Chr(10)
bShowMiss = False 'Voreinstellung: keine Fehlermeldung
With wksData
'Blatt schützen mit Passwort. Wenn das Blatt schon geschützt ist,
'wird der Schutz trotzdem neu gesetzt. Userinterfaceonly(True) erlaubt VBA,
'trotz Blattschutz die Zellen zu ändern!
wksArchiv.Protect Password:="Sport", userinterfaceonly:=True
'lezte Zeile automatisch ermitteln
lRowLastName = .Cells(Rows.Count, iColNames).End(xlUp).Row
'jeden Namen einzeln durchgehen
For Each rNames In .Range(.Cells(lRowFirstName, iColNames), .Cells(lRowLastName, _
iColNames))
'Wächter setzen
bDoIt = True
'prüfe ob Name oder beide leer. Die Wächtervariable bDoIt verhindert dann,
'dass "Namen/Datum holen" ausgeführt wird.
'Wenn nur der Name fehlt, Fehlermeldung schreiben.
If rNames.Value = "" Then
'prüfe ob auch das Datum fehlt
If .Cells(rNames.Row, iColDates).Value = "" Then
'wenn beides fehlt, nix! (aber auch kein Datum eintragen)
bDoIt = False
Else
'sonst meckern und diesen überspringen
'sMissDate = sMissDate & rNames.Address & Chr(10)
sMissName = sMissName & rNames.Address & Chr(10)
bShowMiss = True 'Fehlermeldung am Ende zeigen
bDoIt = False
End If
Else
'prüfe ob nur das Datum fehlt, Fehlermeldung schreiben.
If .Cells(rNames.Row, iColDates).Value = "" Then
sMissDate = sMissDate & .Cells(rNames.Row, iColDates).Address & Chr(10)
bShowMiss = True 'Fehlermeldung am Ende zeigen
bDoIt = False
End If
End If
If bDoIt Then
'gibt es den Namen schon im Archiv?
If Application.WorksheetFunction.CountIf(wksArchiv.Cells(lRowNameArchiv, 1). _
EntireRow, rNames.Value) = 1 Then
'Namen gibts schon, mache nix
Else
'Name fehlt, Name nachtragen
iColLast = wksArchiv.Cells(lRowNameArchiv, Columns.Count).End(xlToLeft). _
Column + 1
wksArchiv.Cells(lRowNameArchiv, iColLast).Value = rNames.Value
End If
'Datum eintragen (den Namen gibt es ja jetzt)
iColLast = Application.WorksheetFunction.Match(rNames.Value, wksArchiv.Cells( _
lRowNameArchiv, 1).EntireRow, False)
lRowLast = wksArchiv.Cells(Rows.Count, iColLast).End(xlUp).Row + 1
'prüfe ob das Datum doppelt ist
If Application.WorksheetFunction.CountIf(wksArchiv.Range(wksArchiv.Cells( _
lRowNameArchiv + 1, iColLast), wksArchiv.Cells(lRowLast, iColLast)), .Cells(rNames.Row, iColDates)) = 0 Then
'wenn das Datum bisher 0-mal vorkommt, trage es ein.
wksArchiv.Cells(lRowLast, iColLast).Value = .Cells(rNames.Row, iColDates)
Else
'wenn das Datum bereits 1-mal vorkommt, mache nix.
'wenn es 2-mal vorkommt, ist irgendwas kaputt! Meckern! (dürfte nie _
passieren)
If Application.WorksheetFunction.CountIf(wksArchiv.Range(wksArchiv.Cells( _
lRowNameArchiv + 1, iColLast), wksArchiv.Cells(lRowLast, iColLast)), .Cells(rNames.Row, iColDates)) >= 2 Then
MsgBox ("ACHTUNG! Ein Datum steht doppelt im Archiv! Bitte Einträge für _
" & rNames.Value & " prüfen")
End If
End If
'aktive Spalte sortieren
Dim rSortRange As Range
With wksArchiv
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range(.Cells(lRowNameArchiv + 1, iColLast), . _
Cells(lRowLast, iColLast)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SetRange Range(.Cells(lRowNameArchiv, iColLast), .Cells(lRowLast, _
iColLast))
.Sort.Header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply
End With
End If
Next rNames
'falls Namen / Datümer fehlten, Fehlermeldung anzeigen
If bShowMiss Then
Debug.Print sMissDate
Debug.Print sMissName
MsgBox sMissDate & Chr(10) & sMissName
End If
End With
End If 'MsgBox "Datum richtig?"
End Sub
Grüße,
Klaus M.vdT.