Option Explicit
Type myMldg_Structure
s_Knr As String
s_Datum As String
s_Vorname As String
s_Name As String
l_KontaktVorAnzTage As Long
s_Telefon1 As String
s_Telefon2 As String
s_Telefon3 As String
End Type
->### A N P A S S E N ###################
->Definitionen zum zu untersuchenden Blatt
Const c_BLATTNAME = Tabelle1
Const c_SP_KNR = 1 ->Spalte A
Const c_SP_DATUM = 3 ->Spalte C
Const c_SP_VORNAME = 5 ->Spalte E
Const c_SP_NAME = 6 'Spalte F
Const c_SP_TELEFON1 = 10 ->Spalte J
Const c_SP_TELEFON2 = 11 ->Spalte K
Const c_SP_TELEFON3 = 13 ->Spalte M
Const c_Z_ERSTEWERTZEILE = 2
->Schwellwert Datum, vor dem gemeldet werden soll (ca. 10 Monate)
Const c_SCHWELLWERT_ANZAHLTAGE = 300
->### A N P A S S E N - E N D E #########
->max. Meldungsanzahl
Const c_MAXANZAHLMELDUNGEN = 12
->Meldungsfeld
Global f_Mldg() As myMldg_Structure, f_Mldg_cnt As Long
'****************************************************************
Sub Excel_DatumUeberwachenMeldung()
If Not Excel_DatumUeberwachenMeldungZusammenstellen Then
MsgBox (Fehler bei der Meldungszusammenstellung.)
GoTo AUFRAEUMEN
End If
If Not Excel_DatumUeberwachenMeldungAusgeben Then
MsgBox (Fehler bei der Meldungsausgabe.)
GoTo AUFRAEUMEN
End If
AUFRAEUMEN:
End Sub
'****************************************************************
Private Function Excel_DatumUeberwachenMeldungDrucken() As Boolean
Const c_DrSP_Knr = 1
Const c_DrSP_Vorname = 2
Const c_DrSP_Name = 3
Const c_DrSP_Datum = 4
Const c_DrSP_VorAnzTg = 5
Const c_DrSP_Telefon1 = 6
Const c_DrSP_Telefon2 = 7
Const c_DrSP_Telefon3 = 8
Const c_DrSP_AnzahlSpalten = 8
Dim l_zeile As Long, x As Long
Dim wb As Workbook, ws As Worksheet, r As Range
Excel_DatumUeberwachenMeldungDrucken = False
Application.ScreenUpdating = False
->temporäre Mappe anlegen
Set wb = Workbooks.Add
Set ws = wb.Worksheets(1)
->Zellen als Text formatieren, Ausrichtung links,oben
With ws.Range(Cells(1, 1), Cells(f_Mldg_cnt + 1, c_DrSP_AnzahlSpalten))
.NumberFormat = @
.VerticalAlignment = xlVAlignTop
.HorizontalAlignment = xlHAlignLeft
With .Borders(xlEdgeLeft): .LineStyle = xlContinuous: .Weight = xlThin: End With
With .Borders(xlEdgeTop): .LineStyle = xlContinuous: .Weight = xlThin: End With
With .Borders(xlEdgeBottom): .LineStyle = xlContinuous: .Weight = xlThin: End With
With .Borders(xlEdgeRight): .LineStyle = xlContinuous: .Weight = xlThin: End With
With .Borders(xlInsideVertical): .LineStyle = xlContinuous: .Weight = xlThin: End With
With .Borders(xlInsideHorizontal): .LineStyle = xlContinuous: .Weight = xlThin: End With
End With
l_zeile = 1
->Überschriften
With ws.Cells(l_zeile, c_DrSP_Knr): .Value = KNr: .Font.Bold = True: End With
With ws.Cells(l_zeile, c_DrSP_Vorname): .Value = Vorname: .Font.Bold = True: End With
With ws.Cells(l_zeile, c_DrSP_Name): .Value = Name: .Font.Bold = True: End With
With ws.Cells(l_zeile, c_DrSP_Datum): .Value = letzter Kontakt: .Font.Bold = True: End With
With ws.Cells(l_zeile, c_DrSP_VorAnzTg): .Value = Kontakt vor Anz. Tagen: .Font.Bold = True: End With
With ws.Cells(l_zeile, c_DrSP_Telefon1): .Value = Telefon 1: .Font.Bold = True: End With
With ws.Cells(l_zeile, c_DrSP_Telefon2): .Value = Telefon 2: .Font.Bold = True: End With
With ws.Cells(l_zeile, c_DrSP_Telefon3): .Value = Telefon 3: .Font.Bold = True: End With
->Werte ausgeben
For x = 1 To f_Mldg_cnt
l_zeile = l_zeile + 1
ws.Cells(l_zeile, c_DrSP_Knr).Value = f_Mldg(x).s_Knr
ws.Cells(l_zeile, c_DrSP_Vorname).Value = f_Mldg(x).s_Vorname
ws.Cells(l_zeile, c_DrSP_Name).Value = f_Mldg(x).s_Name
ws.Cells(l_zeile, c_DrSP_Datum).Value = f_Mldg(x).s_Datum
If f_Mldg(x).s_Datum = Then
ws.Cells(l_zeile, c_DrSP_VorAnzTg).Value = nie
Else
ws.Cells(l_zeile, c_DrSP_VorAnzTg).Value = f_Mldg(x).l_KontaktVorAnzTage
End If
ws.Cells(l_zeile, c_DrSP_Telefon1).Value = f_Mldg(x).s_Telefon1
ws.Cells(l_zeile, c_DrSP_Telefon2).Value = f_Mldg(x).s_Telefon2
ws.Cells(l_zeile, c_DrSP_Telefon3).Value = f_Mldg(x).s_Telefon3
Next
->Spaltenbreite optimieren
For x = 1 To ws.UsedRange.Columns.Count: ws.Columns(x).AutoFit: Next
With ws.PageSetup
->Seitenformat - Querformat
.Orientation = xlLandscape
->Ausgabe 1 Seite breit
.Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = 9999
->Seitenüberschrift
.CenterHeader = &Arial,Fett&12 & zu kontaktierende Kunden
.RightHeader = &9&D, &T->Datum
.CenterFooter = &9&P/&N->Seite / Seiten
End With
Application.ScreenUpdating = True
->Ausdrucken
->ws.UsedRange.PrintOut
->für Test
ws.UsedRange.PrintOut Preview:=True
->temporäre Datei schliessen ohne Speichern
wb.Close savechanges:=False
->Rückgabekennung
Excel_DatumUeberwachenMeldungDrucken = True
AUFRAEUMEN:
Set ws = Nothing: Set wb = Nothing
End Function
Private Function Excel_DatumUeberwachenMeldungAusgeben() As Boolean
Dim s_Mldg As String, s_Kunde As String, x As Long, ret As Integer, s_Telefon As String
Excel_DatumUeberwachenMeldungAusgeben = False
->Nichts zu melden ?
If f_Mldg_cnt = 0 Then
MsgBox ( _
Alle Kunden wurden in den letzten & c_SCHWELLWERT_ANZAHLTAGE & Tagen kontaktiert.)
Excel_DatumUeberwachenMeldungAusgeben = True
GoTo AUFRAEUMEN
End If
->Meldung zusammenstellen
s_Mldg =
For x = 1 To f_Mldg_cnt
If x > 1 Then s_Mldg = s_Mldg & vbLf->nächste Zeile
->Telefonnummern-String aufbereiten
s_Telefon = TelefonnummernAusgabestring(x)
->Kunde aufbereiten
s_Kunde = Kunde & f_Mldg(x).s_Knr & ( & f_Mldg(x).s_Vorname & , & f_Mldg(x).s_Name & )
If f_Mldg(x).s_Datum = Then
s_Mldg = s_Mldg & s_Kunde & wurde nie kontaktiert! & s_Telefon
Else
s_Mldg = s_Mldg & _
s_Kunde & wurde vor & f_Mldg(x).l_KontaktVorAnzTage & Tagen kontaktiert! & _
s_Telefon
End If
->maximale Anzahl Meldungen für Msgbox erreicht ?
If x = c_MAXANZAHLMELDUNGEN Then
If f_Mldg_cnt > c_MAXANZAHLMELDUNGEN Then
s_Mldg = s_Mldg & vbLf & vbLf & _
nicht ausgegeben Meldungen: & (f_Mldg_cnt - c_MAXANZAHLMELDUNGEN)
Exit For
End If
End If
Next
ret = MsgBox( _
s_Mldg & vbLf & vbLf & Soll das gedruckt werden ?, _
vbDefaultButton1 + vbYesNo)
If ret = vbYes Then
If Not Excel_DatumUeberwachenMeldungDrucken Then
MsgBox (Fehler bei Meldung drucken.)
GoTo AUFRAEUMEN
End If
End If
Excel_DatumUeberwachenMeldungAusgeben = True
AUFRAEUMEN:
End Function
'****************************************************************
Private Function Excel_DatumUeberwachenMeldungZusammenstellen() As Boolean
'***
'*** Stellt die zu meldenden Kundendaten im Meldungsfeld zusammen
'***
Dim ws As Worksheet, l_rows As Long, x As Long
Dim d_Datum As Date, d_Datum_Schwellwert As Date, d_Datum_Heute As Date
Excel_DatumUeberwachenMeldungZusammenstellen = False
->Meldungsfeld Initialisieren
f_Mldg_cnt = 0
ReDim f_Mldg(1 To 1)
On Error Resume Next
Set ws = Worksheets(c_BLATTNAME)
If Err.Number <> 0 Then
Err.Clear
MsgBox (Blatt-> & c_BLATTNAME &-> ist nicht vorhanden.)
GoTo AUFRAEUMEN
End If
->Anzahl relevanter Zeilen feststellen
l_rows = ws.Cells(ws.Rows.Count, c_SP_DATUM).End(xlUp).Row
->Datum Schwellwert berechnen
d_Datum_Heute = Format(Now(), dd.mm.yyyy)
d_Datum_Schwellwert = d_Datum_Heute - c_SCHWELLWERT_ANZAHLTAGE
->alle relevanten Zeilen untersuchen
For x = c_Z_ERSTEWERTZEILE To l_rows
d_Datum = ws.Cells(x, c_SP_DATUM).Value
If d_Datum < d_Datum_Schwellwert Then
->Werte des Kunden in Meldungsfeld
f_Mldg_cnt = f_Mldg_cnt + 1
ReDim Preserve f_Mldg(1 To f_Mldg_cnt)
With f_Mldg(f_Mldg_cnt)
.s_Datum = ws.Cells(x, c_SP_DATUM).Value
.l_KontaktVorAnzTage = (d_Datum_Heute - d_Datum)
.s_Knr = ws.Cells(x, c_SP_KNR).Value
.s_Name = ws.Cells(x, c_SP_NAME).Value
.s_Vorname = ws.Cells(x, c_SP_VORNAME).Value
.s_Telefon1 = ws.Cells(x, c_SP_TELEFON1).Value
.s_Telefon2 = ws.Cells(x, c_SP_TELEFON2).Value
.s_Telefon3 = ws.Cells(x, c_SP_TELEFON3).Value
End With
End If
Next
->Rückgabekennung ok setzen
Excel_DatumUeberwachenMeldungZusammenstellen = True
AUFRAEUMEN:
Set ws = Nothing
On Error GoTo 0
End Function
'****************************************************************
Private Function TelefonnummernAusgabestring(l_ind As Long) As String
Dim f() As String, f_cnt As Long, s_Tel As String, x As Long
f_cnt = 0: ReDim f(1 To 1)
If f_Mldg(l_ind).s_Telefon1 <> Then
f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
f(f_cnt) = f_Mldg(l_ind).s_Telefon1
End If
If f_Mldg(l_ind).s_Telefon2 <> Then
f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
f(f_cnt) = f_Mldg(l_ind).s_Telefon2
End If
If f_Mldg(l_ind).s_Telefon3 <> Then
f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
f(f_cnt) = f_Mldg(l_ind).s_Telefon3
End If
s_Tel = ( Telefon:
If f_cnt = 0 Then
s_Tel = s_Tel & keine Angabe
Else
s_Tel = s_Tel & f(1) &
For x = 2 To f_cnt: s_Tel = s_Tel & oder & f(x) & : Next
End If
s_Tel = s_Tel & )
TelefonnummernAusgabestring = s_Tel
End Function