AW: Tabelle durchsuchen
25.08.2017 15:18:24
Piet
Hallo Alex
anbei ein Code der in ein normales modul kopiert werden muss. Im CommandButton Modul dem Button dieses Makro zuweisen mit: Call Kalender_ausfüllen - Es sollte laufen, ist getestet.
Ich gehe davon aus das beim neu befüllen die alten Daten gelöscht werden sollen. Ist eine Zelle bereits belegt kommt eine Warnung und kein Eintrag in diese Zelle! Im Programm gibt es mehrer Prüfungen, ob die Kunden Nr. immer gefunden wird, oder wenn Datum/ Zeit nicht mit dem Kalender übereinstimmt. Das muss du dann manuell prüfen.
Würde mich freuen wenn das Makro so bracubar ist.
mfg Piet
Option Explicit '25.8.2017 Piet Herber Forum
Dim AC As Range, AJ As Range
Dim zKd As Long, Txt As String
Dim sp As Integer, ze As Integer
Dim Tag As Date, Zeit As Variant
'Modul für Kalender ausfüllen
Sub Kalender_ausfüllen()
Dim Kd As Worksheet, lzKd As Long
Dim AWF As Worksheet, lzAw As Long
Set AWF = Worksheets("AWF")
Set Kd = Worksheets("Kunden")
'LastZell in Kunden + AWF ermitteln
lzKd = Kd.Range("A1").End(xlDown).Row
lzAw = AWF.Range("AA1").End(xlDown).Row
Worksheets("Kal").Select
With Worksheets("Kal")
'alte Kalender Daten löschen
.Range("B9:F29").ClearContents
For Each AC In AWF.Range("AA2:AA" & lzAw)
Tag = AC.Offset(0, 1).Value
Zeit = AC.Offset(0, 4).Value
zKd = Empty 'Kunden-Nr löschen
'Kunden Zeile in "Kunden" Sht suchen
For Each AJ In Kd.Range("A2:A" & lzKd)
If AC.Value = AJ.Value Then zKd = AC.Row
Next AJ
'akt. Tag in Kalender Spalten suchen
For sp = 2 To 7
If .Cells(6, sp) = Tag Then Exit For
Next sp
'Uhrzeit in Kalender Zeilen suchen
For ze = 9 To 30
If .Cells(ze, 1) = Zeit Then Exit For
Next ze
'Fehlermeldung wenn Kunden-Nr in "Kunden" Blatt nicht gefunden wird !!
If zKd = Empty Then MsgBox AC.Value & " Kunden Nr in 'Kunden' Blatt nicht gefunden !!": _
: GoTo nxt
'Fehlermeldung wenn Tag/Zeit im Kalender nicht gefunden wird !!
If sp = 7 Then MsgBox Tag & " Tag im Kalender nicht gefunden !!": GoTo nxt
If ze = 30 Then MsgBox Zeit & " Zeit im Kalender nicht gefunden !!": GoTo nxt
'Text String für Eintrag in kalender (oder Fehlermeldung)
Txt = AC.Value & " " & Kd.Cells(zKd, 2) & " " & Kd.Cells(zKd, 3)
If .Cells(ze, sp) = "" Then
'Text String in Kalender eintragen
.Cells(ze, sp) = Txt
Else 'Zelle schon belegt:
.Cells(ze, sp).Select
MsgBox "Zelle bereits belegt" & vbLf & "neuer Kunde:" & vbLf & Txt
End If
nxt:
Next AC
End With
End Sub
