AW: Das sieht schon richtig GUT aus, aber ;o)
01.09.2006 08:34:51
{mskro}
Hallo Uwe,
ich finde es toll, das du dich meines Problems mal angenommen hast. Ich habe es auf meinem Rechner laufen lassen. Es ist noch nicht ganz funktionsfähig, aber doch schon sehr gut. *ich bin begeistert*
Lasse mich noch ein paar Erklärungen dazu abgeben, was noch nicht so richtig funktioniert.
Wie du gesehen hast, habe ich in der Druckvorlage 2 Vorlagen, die es gilt für die 4 benötigten Ausdrucke zu benutzen. Darum müßen die Tageszahlen der Monate angepasst werden.
Ebenfalls werden die Monatsnamen noch nicht eigetragen.
Ich habe nun mal folgendes gemacht (mit meinen VBA Kenntnissen)
Ich habe einfach mal ein 3. und 4. Blatt in der Druckvorlage eingefügt und das Makro dementsprechen eingefügt. (Besser wäre allerdings, es bleibt bei den 2)
Nur werden jetzt die Geburtstage, die ich dann in die Tabelle eingefügt habe leider nicht immer den richtigen Monaten zugeordnet.
Ich füge das geänderte Makro mal bei, vielleicht erkennst du ja Fehler, die ich bei der Umsetzung gemacht habe.
Achja... Das Schaltjahr ist in diesem Fall egal, da es sich nur um einen Geburtstagskalender handelt und nicht Jahresgebunden ist. Der Februar sollte dann einfach mit "28" eingetragen werden. Falls dann doch mal einer auf dem 29. Geburtstag haben sollte, steht eben vor dem Namen kein 29.
Option Explicit
Sub Start()
Dim wbG As Workbook, _
wbD As Workbook
Dim shtG As Worksheet, shtD(4) As Worksheet
Dim rngG As Range, rngD() As Range
Dim lngMaxRecs As Long
Dim strGFName As String, strDFName As String
Dim strDay As String, iPosDot As Integer, TT As Integer, MM As Integer
Dim wsDNr As Integer, cDNr As Integer, strName As String, iDRowOffset As Integer
Dim strDirName As String, strWorkDir As String
strGFName = "succes-geburtstage.xls"
strDFName = "succes-druckvorlage.xls"
strWorkDir = "C:\Dokumente und Einstellungen\" & _
Environ("Username") & _
"\Desktop\"
Set wbG = Application.Workbooks.Open(strWorkDir & strGFName)
If wbG Is Nothing Then
MsgBox strGFName & vbLf & "konnte nicht geöffnet werden"
Set wbG = Nothing
Set wbD = Nothing
Exit Sub
End If
Set wbD = Workbooks.Open(strWorkDir & strDFName)
If wbG Is Nothing Then
MsgBox strDFName & vbLf & "konnte nicht geöffnet werden"
Set wbG = Nothing
Set wbD = Nothing
Exit Sub
End If
Set shtG = wbG.Sheets("Tabelle1")
Set shtD(1) = wbD.Sheets("Seite1") 'Monate 7 8 1 2
Set shtD(2) = wbD.Sheets("Seite2") 'Monate 3 4 5 6
Set shtD(3) = wbD.Sheets("Seite1") 'Monate 1 1 9 10
Set shtD(4) = wbD.Sheets("Seite4") 'Monate 11 12 1 1
iDRowOffset = 2 'Kopfzeilen in der Druckvorlage vor dem ersten Monatstag
With shtG
lngMaxRecs = .Cells(Rows.Count, 1).End(xlUp).Row
For Each rngG In .Range("A2:A" & lngMaxRecs)
strDay = rngG.Value
iPosDot = InStr(strDay, ".")
TT = Val(Left(strDay, iPosDot - 1))
MM = Val(Mid(strDay, iPosDot + 1))
'Bestimme Druckseite nach MM
Select Case MM
Case 7, 8, 1, 2: wsDNr = 1
Case 3, 4, 5, 6: wsDNr = 2
Case 13, 13, 9, 10: wsDNr = 3'die 13 darum, weil ich dachte schon vorhandene Monate machen Schwierigkeiten
Case 11, 12, 13, 13: wsDNr = 4
Case Else
MsgBox "Unzulässige Monatszahl in " & strDay
wsDNr = 0
End Select
If wsDNr Then
'Bestimme Druckspalte nach MM
'(Spalten auf Druckvorlageseite 3 prüfen!)
Select Case MM
Case 7, 3, 3, 11: cDNr = 5 'Spalte E
Case 8, 4, 4, 12: cDNr = 9 'Spalte I
Case 1, 5, 9, 1: cDNr = 18 'Spalte R
Case 2, 6, 10, 12: cDNr = 22 'Spalte V
End Select
strName = rngG.Offset(0, 1) 'Geburtstagseintrag
If shtD(wsDNr).Cells(TT + iDRowOffset, cDNr).Value Then
MsgBox "Zelle bereits belegt"
Else
'-------------- Nur für die Testphase
' shtD(wsDNr).Select
' shtD(wsDNr).Cells(TT + iDRowOffset, cDNr).Select
' MsgBox "Der Eintrag für " & _
' vbLf & vbTab & strDay & " | " & strName & _
' vbLf & "erfolgt in Adresse " & _
' shtD(wsDNr).Cells(TT + iDRowOffset, cDNr).Address
'Nachfolgende Zeile (über-)schreibt den Namenseintrag _
'in der Druckvorlage
shtD(wsDNr).Cells(TT + iDRowOffset, cDNr) = strName
End If
End If
Next
End With
'Druckvoralage ist ausgefüllt
'das Löschen von 31. in den Monaten 2,4,6,9 und 11 soltte im Laxout der Vorlage
'erledigt werden,
'Das Löschen des 30. und schaltjahrabhängig des 29. beding die Vorgabe des Jahres,
'das hier nicht eingeführt wurde
For wsDNr = 1 To 3
shtD(wsDNr).PrintPreview
'shtD(wsDNr).Printout '... ggf. parameter
Next wsDNr
wbG.Close
wbD.Close
Set wbG = Nothing
Set shtD(1) = Nothing: Set shtD(2) = Nothing: Set shtD(3) = Nothing
End Sub
Gruss Manfred
PS: Auf jeden Fall schon mal meinen RIESEN DANK dafür, was du mir hier gebastelt hast. Vielleicht werden meine Wünsche ja doch noch wahr und ich habe mal die Lösung für das Problem.