Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1360to1364
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Datumsbereich markieren

Datumsbereich markieren
08.05.2014 16:13:08
Thomas
Hallo,
ich stehe vor einem kleinen Problem und komme nicht weiter, vielleicht kann mir ja mal jemand helfen.
Ich habe mir einen Kalender gebastelt und noch ein paar mehr funktionen.
Leider ist die Datei zu groß, daher kann ich nur eine "kleine" Version davon hier hochladen.
Datei: --- https://www.herber.de/bbs/user/90571.xlsm
Aber für mein Problem ist das auch nicht weiter relevant.
Nun zu meinem Problem:
Die Werte auf dem Tabellenblatt "Azubis_nur_Werte" werden mit hilfe einiger berechnungen und VBA erzeugt. Dabei wird per VBA alles errechnet und dann in diesen Tabellenblatt in die erste freie Zeile geschrieben.
Nun habe ich es geschafft, dass ich per VBA den vor und Nachnahmen dann auf dem Tabellenblatt "Übersicht" unter Azubis eingetragen bekommen. Dies funktioniert auch nach dem Prinzip "erste freie Zeile".
Der Kalender hat noch weitere Zeilen. (Musste sie nur rausnehmen da die Datei sonst zu groß wäre)
Habe verschiedenen Zeilen Bereichsnahmen gegeben. Diese lauten genauso wie die Abteilungen auf Blatt "Azubis_nur_Werte".
Mein wunsch wäre es, dass Excel per VBA Daten aus dem Tabellenblatt "Azubis_nur_Werte" im Kalender markiert.
Beispiel:
Prüfe letzte beschriebene Zeile "Azubis_nur_Werte" ,-,
Wenn Abteilung 1 = BereichsnahmeXY dann markiere Datum beginn Abteilung1 bis Datum Ende Abteilung1 in der Farbe aus Spalte E(selbe Zeile)
Wenn Abteilung 2 = BereichsnahmeXY dann markiere Datum beginn Abteilung2 bis Datum Ende Abteilung2 in der Farbe aus Spalte E(selbe Zeile)
usw. für alle 7 Abteilungen.
Ziel:
Der Azubi hat 7 Abteilungen die er in bestimmter Zeit belegt. Der Azubi hat eine bestimmte Farbe (Spalte E). Es wird im Kalender die Abteilung und der Bereich markiert der mit den Datumsangaben vorgegeben wurde.
Ich hoffe ich konnte es verständlich rüber bringen was ich erreichen möchte.
Natürlich gibt es in der Datei Abteilungen die jetzt nicht im Kalender stehen, musste diese rausnehmen da sonst die Datei zu groß für den Upload wäre.
Danke schon mal für eure Hilfe.
Gruß
Thomas

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Datumsbereich markieren
09.05.2014 08:13:56
fcs
Hallo Thomas,
hier mal ein Anfang für die Markierung,
die Verarbeitung von fehlenden/falschen Eingaben muss du ggf. noch anpassen. Im Moment erscheinen Meldungen.
Gruß
Franz
Sub Abteilungen_markieren()
Dim Zeile_L As Long
Dim Spalte As Long, SpalteDatum As Long
Dim DatBeginn As Date, DatEnde As Date, strAbt As String
Dim intC As Integer
Dim wksAzubi As Worksheet
Dim bolOK As Boolean
Set wksAzubi = ActiveWorkbook.Worksheets("Azubis_nur_Werte")
With wksAzubi
Zeile_L = .Cells(.Rows.Count, 3).End(xlUp).Row 'letzte zeile mit Name
intC = 0 'Startzähler für Abteilungen setzen
For Spalte = 6 To 12 'Spalten mit den Abteilungsbezeichnungen
strAbt = Trim(.Cells(Zeile_L, Spalte))
SpalteDatum = 13 + intC * 2 'Spalte mit Beginn Abteilung
bolOK = True
If IsDate(.Cells(Zeile_L, SpalteDatum)) Then
DatBeginn = .Cells(Zeile_L, SpalteDatum)
Else
bolOK = False
MsgBox "Eingabe zu Beginndatum fehlt in Zeile " & Zeile_L & " für " & .Cells(1, Spalte)
End If
If IsDate(.Cells(Zeile_L, SpalteDatum + 1)) Then
DatEnde = .Cells(Zeile_L, SpalteDatum + 1)
Else
bolOK = False
MsgBox "Eingabe zu Endedatum fehlt in Zeile " & Zeile_L & " für " & .Cells(1, Spalte)
End If
If bolOK = True Then
Call Datumsbereich_markieren(strAbteilung:=strAbt, _
Farbe:=.Cells(Zeile_L, 5).Interior.Color, _
DatumStart:=DatBeginn, _
DatumEnde:=DatEnde)
End If
intC = intC + 1
Next
End With
End Sub
Private Sub Datumsbereich_markieren(strAbteilung As String, Farbe As Long, DatumStart As Date,  _
_
DatumEnde As Date)
Dim Zeile As Long, Spalte_Start As Long, Spalte_Ende As Long
Dim strBereich As String
'Bereichsnamen zu Abteilungen zuweisen
strBereich = ""
Select Case strAbteilung
Case "Office Service": strBereich = "?"
Case "PF MM": strBereich = "PF_MM"
Case "Customer Service - Logistic / Inco": strBereich = "?"
Case "Supply Service": strBereich = "Supply_Service"
Case "Finanz/-rechnungswesen": strBereich = "?"
Case "HR": strBereich = "?"
Case "BRT": strBereich = "?"
End Select
If strBereich = "" Or strBereich = "?" Then
MsgBox "Für Abteilung """ & strAbteilung _
& """ fehlt noch eine Case Zeile mit der Bereichszuweisung", _
vbInformation + vbOKOnly, "Makro: Datumsbereich_markieren"
Else
With Worksheets("übersicht")
Zeile = .Range(strBereich).Row
Spalte_Start = 3 + DatumStart - .Range("A1").Value + 1
Spalte_Ende = 3 + DatumEnde - .Range("A1").Value + 1
.Range(.Cells(Zeile, Spalte_Start), .Cells(Zeile, Spalte_Ende)).Interior.Color = Farbe
End With
End If
End Sub

Anzeige
AW: Datumsbereich markieren
09.05.2014 14:29:59
Thomas
Das ist echt der HAMMER!!!!!!!!!!!!
Ich habe die Bereiche noch angepasst und meine Code mit dazu gepackt und er macht genau das was er soll!!!
1000 Dank
Hier nochmal für alle die es vielleicht mal brauch könnten oder auch Verbesserungen für Effizienz usw. haben mein gesamter Code:

Option Explicit                                                                                  _
'Hiermit wird verlangt, dass alle benutzten Variablen definiert werden.
Option Compare Text                                                                              _
'Hiermit wird festgelegt, dass bei Vergleichs-Operationen (Like, Find...)                                                                                                'NICHT zwischen Groß/Klein-Schreibung unterschieden wird.
Private Sub AzubiQuelldaten_anlegen()
'Modul 2 und Modul 4 zusammenfügen
Dim varX As Variant, lngIndex As Long, lngRow As Long, Wks1 As Worksheet, Wks2 As Worksheet,  _
Found As Range, c As Range, Spalte As Long, LZeile As Long, letzteZeileA As Long, letzteZeileB As Long, letzteZeileC As Long, Farbe As Long, Rot As Long, Gruen As Long, Blau As Long, lZeileB As Long, lZeileC As Long, lZeileA As Long             'deklaration
varX = Array("B6", "B2", "B3", "F3", "B4", "C10", "C11", "C12", "C13", "C14", "C15", "C16") 'zu  _
kopierende Zellen (unbegrenzt Erweiterbar)
With ThisWorkbook.Worksheets("Azubis") 'Ziel der kopierten Zellen
lngRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 'prüfe Ende der letzten gefüllten Zeile  _
und addiere +1 Zeile
For lngIndex = 0 To UBound(varX) ' welche Variabeln sollen kopiert werden
.Cells(lngRow, lngIndex + 1) = ActiveWorkbook.Worksheets("Auszubildender").Range(varX( _
lngIndex)).Value 'ab welcher Spalte (von links aus gesehen) soll eingefügt werden, und was ist die Quelle der zu kopierenden Zellen
Next
End With
varX = Array("A2", "B2", "C2", "D2", "E2", "F2", "G2", "H2", "I2", "J2", "K2", "L2", "M2", "N2", _
"O2", "P2", "Q2", "R2", "S2", "T2", "U2", "V2", "W2", "X2", "Y2", "Z2") 'zu kopierende Zellen (unbegrenzt Erweiterbar)
With ThisWorkbook.Worksheets("Azubis_nur_Werte") 'Ziel der kopierten Zellen
lngRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 'prüfe Ende der letzten gefüllten Zeile  _
und addiere +1 Zeile
For lngIndex = 0 To UBound(varX) ' welche Variabeln sollen kopiert werden
.Cells(lngRow, lngIndex + 1) = ActiveWorkbook.Worksheets("Azubis").Range(varX(lngIndex)). _
Value 'ab welcher Spalte (von links aus gesehen) soll eingefügt werden, und was ist die Quelle der zu kopierenden Zellen
Next
End With
ThisWorkbook.Worksheets("Azubis").Rows("2:2").SpecialCells(xlCellTypeConstants, 23). _
ClearContents
Set Wks1 = Sheets("Ergebnis_Schulzeiten"):  Set Wks2 = Sheets("Azubis_nur_Werte")                _
'Bei Abläufen in verschiedenen Tabs empfielt es sich, die Tabellenblätter explizit
_
'einer Variablen zuzuordnen und diese darüber anzusprechen.
Application.ScreenUpdating = False                                                           _
'Deaktiviert die Bildschirmaktualisierung während der Makro-Ausführung.
With Wks1                                                                                    _
'Das Makro wird schneller ausgeführt und der Bildschirm flackert nicht.
lngRow = .Cells(.Rows.Count, 25).End(xlUp).Row
_
'Alle nachfolgenden Anweisungen, die mit einem Punkt beginnen, sind dem
LZeile = Wks2.[a65536].End(xlUp).Offset(0, 27).Row
' _
Tabellenblatt Wks1 zuzuordnen.
For Each c In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)                       ' _
c steht für jede einzelne Zelle im Bereich A2:A & Letzte Zeile mit Inhalt in Spalte A
If Not IsEmpty(c) Then                                                               _
'Keine leere Zellen
Set Found = Wks2.Columns("D").Find(c, LookIn:=xlValues, LookAt:=xlWhole)         _
'Found ist Zelle, in der der Wert gefunden wurde (xlWohle vergleicht ganzen Zellinhalt)
If Not Found Is Nothing Then                                                    _
'Wenn gefunden dann
_
'Zeile mit Suchwert kopieren und in der selben Zeile (wo wert gefunden) einfügen
.Range(c.Offset(0, 25), c).Copy Wks2.Cells(LZeile + (Spalte), 27)            _
'erste leere Zelle in Spalte AA finden und dort einfügen
End If
End If
Next
End With
Application.CutCopyMode = False:  Application.ScreenUpdating = True                          _
'Die Kopiermarkierung aufheben und die Bildschirmaktualisierung wieder aktivieren
Set Wks1 = Sheets("Azubis_nur_Werte")
Set Wks2 = Sheets("Auszubildender")
letzteZeileA = Wks1.Cells(Rows.Count, 4).End(xlUp).Row
Farbe = Wks2.Cells(4, 2).Interior.Color
On Error Resume Next
Rot = Farbe Mod 256
Farbe = (Farbe - Rot) / 256
Gruen = Farbe Mod 256
Farbe = (Farbe - Gruen) / 256
Blau = Farbe Mod 256
On Error GoTo 0
Wks1.Cells(letzteZeileA, 5).Interior.Color = RGB(Rot, Gruen, Blau)
Set Wks1 = Sheets("Azubis_nur_Werte"):  Set Wks2 = Sheets("Übersicht")
With Wks1
lZeileB = Wks1.Cells(Rows.Count, 2).End(xlUp).Row
lZeileC = Wks1.Cells(Rows.Count, 3).End(xlUp).Row
lZeileA = Wks2.Cells(Rows.Count, 1).End(xlUp).Row
End With
Wks1.Range(Wks1.Cells(lZeileB, 2), Wks1.Cells(lZeileC, 3)).Copy Destination:=Wks2.Cells( _
lZeileA + 1, 1)
Set Wks1 = Sheets("Azubis_nur_Werte")
Set Wks2 = Sheets("Übersicht")
letzteZeileA = Wks1.Cells(Rows.Count, 4).End(xlUp).Row
letzteZeileB = Wks2.Cells(Rows.Count, 1).End(xlUp).Row
Farbe = Wks1.Cells(letzteZeileA, 5).Interior.Color
On Error Resume Next
Rot = Farbe Mod 256
Farbe = (Farbe - Rot) / 256
Gruen = Farbe Mod 256
Farbe = (Farbe - Gruen) / 256
Blau = Farbe Mod 256
On Error GoTo 0
Wks2.Cells(letzteZeileB, 1).Interior.Color = RGB(Rot, Gruen, Blau)
Wks2.Cells(letzteZeileB, 2).Interior.Color = RGB(Rot, Gruen, Blau)
Wks2.Range("A45:A1500").HorizontalAlignment = xlRight
Wks2.Range("B45:B1500").HorizontalAlignment = xlLeft
Call Abteilungen_markieren
MsgBox ("Azubi wurde angelegt.")
End Sub
Public Sub Abteilungen_markieren()
Dim Zeile_L As Long
Dim Spalte As Long, SpalteDatum As Long
Dim DatBeginn As Date, DatEnde As Date, strAbt As String
Dim intC As Integer
Dim wksAzubi As Worksheet
Dim bolOK As Boolean
Set wksAzubi = ActiveWorkbook.Worksheets("Azubis_nur_Werte")
With wksAzubi
Zeile_L = .Cells(.Rows.Count, 3).End(xlUp).Row 'letzte zeile mit Name
intC = 0 'Startzähler für Abteilungen setzen
For Spalte = 6 To 12 'Spalten mit den Abteilungsbezeichnungen
strAbt = Trim(.Cells(Zeile_L, Spalte))
SpalteDatum = 13 + intC * 2 'Spalte mit Beginn Abteilung
bolOK = True
If IsDate(.Cells(Zeile_L, SpalteDatum)) Then
DatBeginn = .Cells(Zeile_L, SpalteDatum)
Else
bolOK = False
MsgBox "Eingabe zu Beginndatum fehlt in Zeile " & Zeile_L & " für " & .Cells(1, Spalte)
End If
If IsDate(.Cells(Zeile_L, SpalteDatum + 1)) Then
DatEnde = .Cells(Zeile_L, SpalteDatum + 1)
Else
bolOK = False
MsgBox "Eingabe zu Endedatum fehlt in Zeile " & Zeile_L & " für " & .Cells(1, Spalte)
End If
If bolOK = True Then
Call Datumsbereich_markieren(strAbteilung:=strAbt, _
Farbe:=.Cells(Zeile_L, 5).Interior.Color, _
DatumStart:=DatBeginn - 1, _
DatumEnde:=DatEnde - 1)
End If
intC = intC + 1
Next
End With
End Sub
Private Sub Datumsbereich_markieren(strAbteilung As String, Farbe As Long, DatumStart As Date,  _
DatumEnde As Date)
Dim Zeile As Long, Spalte_Start As Long, Spalte_Ende As Long
Dim strBereich As String
'Bereichsnamen zu Abteilungen zuweisen
strBereich = ""
Select Case strAbteilung
Case "Office Service": strBereich = "Office_Service"
Case "Warehouse": strBereich = "Warehouse"
Case "PF MM": strBereich = "PF_MM"
Case "Customer Service - Logistic / Inco": strBereich = "Customer_Service_Logistic_Inco"
Case "Supply Service": strBereich = "Supply_Service"
Case "Finanz/-rechnungswesen": strBereich = "Finanz_rechnungswesen"
Case "HR": strBereich = "HR"
Case "BRT": strBereich = "BRT"
Case "TSS Technical Purchase": strBereich = "TSS_Technical_Purchase"
Case "Customer Service CGE (nur IKL)": strBereich = "Customer_Service_GCE"
Case "Customer Service AFH": strBereich = "Customer_Service_AFH"
Case "TSS Magazin": strBereich = "TSS_Magazin"
End Select
If strBereich = "" Or strBereich = "?" Then
MsgBox "Für Abteilung """ & strAbteilung _
& """ fehlt noch eine Case Zeile mit der Bereichszuweisung", _
vbInformation + vbOKOnly, "Makro: Datumsbereich_markieren"
Else
With Worksheets("übersicht")
Zeile = .Range(strBereich).Row
Spalte_Start = 3 + DatumStart - .Range("A1").Value + 1
Spalte_Ende = 3 + DatumEnde - .Range("A1").Value + 1
.Range(.Cells(Zeile, Spalte_Start), .Cells(Zeile, Spalte_Ende)).Interior.Color = Farbe
End With
End If
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige