Makro
27.02.2009 21:21:32
Ralf
Hab ein Problem , habe mir hier aus dem Forum und aus Google ein Kalender gebastelt.
Ich krieg es hin wenn ich Geburtstage eingetragen habe das ich die Zeile unterteile .
Nun zu meinen Problem Ich will Termine eintragen und wenn ich mehr als drei Termine habe
(will nicht mehr Spalten machen als C bis E) soll das makro erkennen das zB. E schon belegt ist
und in C (wenn das auch nicht belegt ist) die zelle unterteilen und dort ablegen . Hat
einer von euch eine Idee und kann mir Helfen .Hir ein ausschnitt aus meinen Programm.
Bitte nicht nach den Daten gucken sind nur von mir irgendwie eingegebene Text bzw Zahlen um zu Testen.
Sub TestTermineEintragen()
Dim termg(100) As Date
Dim namg(100) As String
Dim namRe(100) As String
Dim termf(100) As Date
Dim feiert(100) As String
Dim termRe(100) As Date
Dim zg As Long, m As Long, z As Long, T As Long, zr As Long
Dim lngLast As Long, lngRow As Long, lngLasts As Long, lngRows As Long
Dim e As Long, i As Long
Dim a As Integer, dat As Date
Dim r As Long
On Error Resume Next
With Worksheets("Tabelle21")
zr = 2 'sucht nach Datum von Reminder
Do While Cells(zr, 25) ""
termRe(zr) = Cells(zr, 25)
namRe(zr) = Cells(zr, 27) & " " & Cells(zr, 26)
zr = zr + 1
Loop
For T = 3 To Cells(Rows.Count, 1).End(xlUp).Row 'trägt Termine von Reminder _
ein
m = 2
For e = 2 To zr
If Left(Cells(T, 1), 6) = Left(termRe(e), 6) Then
Cells(T, m + 1).Font.ColorIndex = 26
Cells(T, m + 1).RowHeight = 17
Cells(T, m + 1).Interior.ColorIndex = 34
If Cells(T, m + 1) namRe(e) And Cells(T, m + 1) "" Then
Cells(T, m + 1).RowHeight = 25
Cells(T, m + 1) = Cells(T, m + 1) _
& Chr(10) & namRe(e)
i = InStr(Cells(T, m + 1), Chr(10))
With Cells(T, m + 1).Characters(Start:=1, Length:=40).Font
.FontStyle = "Fett Kursiv"
.Size = 9
.ColorIndex = 5
End With
With Cells(T, m + 1).Characters(Start:=i, Length:=40).Font
.FontStyle = "Fett Kursiv"
.Size = 9
.ColorIndex = 26
End With
Else: Cells(T, m + 1) = namRe(e)
m = m + 1
If Len(Cells(T, m + 1)) > 25 Then _
Cells(T, m + 1).Font.Size = 10
Cells(T, m + 2).Font.Size = 10
End If
End If
Next e
Next T
End With
End Sub
Entschuldigung habe das Problem das mein Arbeitsblatt zu gross ist um eine beispieldatei anzuhängen.
Vielleicht kann auch damit was einer anfangen
Gruss
Ralf