AW: Formatierung einer aus Access importierten Tabelle
12.04.2018 16:19:04
fcs
Hallo Jonas,
hier zwei Makros,
eines erstellt ein Tabellenblatt mit einem Kalender mit den fortlaufenden Tagen für ein Jahr,
Das 2. Überträgt Daten aus deiner Liste in den Kalender.
Gruß
Franz
Sub MakeKalender()
'Erstellt in einem neuen Tabellenblatt einen Kalender mit den Tagen des Jahres in Zeile 2
Dim Jahr As Long
Dim wks As Worksheet
Const SpaDatum1 As Long = 2 'Spale B - Spalte mit dem 1. Datum im Kalender - ggf. anpasen
Const ZeiDatum As Long = 2 'Zeile mit den Datumswerten im Kalender - ggf. anpasen
EingabeJahr:
Jahr = Application.InputBox("Welches Jahr?", "Kalender erstellen", Year(Date), 1)
Select Case Jahr
Case 0
'abgebrochen
Case 1900 To 9999
Set wks = ActiveWorkbook.Worksheets.Add(After:=ActiveSheet)
With wks
.Cells(ZeiDatum - 1, SpaDatum1 - 1) = "Jahr"
.Cells(ZeiDatum - 1, SpaDatum1) = Jahr
.Cells(ZeiDatum, SpaDatum1 - 1) = "Pers.-Nr"
.Cells(ZeiDatum, SpaDatum1) = DateSerial(Jahr, 1, 1) '1. Januar des Jahres
.Cells(ZeiDatum, SpaDatum1).NumberFormat = "DD.MM.YY"
With .Range(.Cells(ZeiDatum, SpaDatum1 + 1), _
.Cells(ZeiDatum, DateSerial(Jahr, 12, 31) - .Cells(ZeiDatum, SpaDatum1) + SpaDatum1))
.NumberFormat = "DD.MM.YY"
.FormulaR1C1 = "=RC[-1]+1"
.Calculate
.Value = .Value
End With
.UsedRange.EntireColumn.AutoFit
ActiveSheet.Cells(ZeiDatum + 1, SpaDatum1 + 1).Select
ActiveWindow.FreezePanes = True
.Name = "Kalender"
End With
Case Else
MsgBox "unzulässiger Wert für Jahr", vbOKOnly, "Kalender erstellen"
GoTo EingabeJahr
End Select
End Sub
Sub AusfuellenKalender()
Dim wksData As Worksheet, Zei_D As Long, objList As ListObject, sListName As String
Dim wksKal As Worksheet, Zei_K As Long, Zei_L As Long
Dim varPersNr, varSchicht, datStart As Date, datEnde As Date
Dim datStartKal As Date, datEndeKal As Date
Dim Spa_K1 As Long, Spa_K2 As Long, Spa_KL As Long
Const SpaDatum1 As Long = 2 'Spale B - Spalte mit dem 1. Datum im Kalender - ggf. anpasen
Const ZeiDatum As Long = 2 'Zeile mit den Datumswerten im Kalender - ggf. anpasen
Set wksKal = ActiveWorkbook.Worksheets("Kalender") 'Blattname ggf. anpassen
Set wksData = ActiveWorkbook.Worksheets("Tabelle2") 'Blattname ggf. anpassen
'Alt-Daten im Kalenderblatt löschen
With wksKal
'letzte Zeile mit Daten in Spalte A
Zei_L = .Cells(.Rows.Count, SpaDatum1 - 1).End(xlUp).Row
If Zei_L > ZeiDatum Then
'vorhandenen Daten löschen
.Range(.Rows(ZeiDatum + 1), .Rows(Zei_L)).ClearContents
End If
'letzte Spalte mit Datumswert
Spa_KL = .Cells(ZeiDatum, .Columns.Count).End(xlToLeft).Column 'letzte Spalte in Zeile 2
'1. Datum im Kalender
datStartKal = .Cells(ZeiDatum, SpaDatum1).Value
'letztes Datum im Kalender
datEndeKal = .Cells(ZeiDatum, Spa_KL).Value
Zei_K = ZeiDatum 'Zeilenzähler für Personal-Nummern im Kalender
End With
'Importierte Personalliste mit Schichtangaben abarbeiten
With wksData
Set objList = .ListObjects(1)
sListName = objList.Name
'Daten in Tabelle (ListObject) sortieren nach Personalnummer und Startdatum
objList.Sort.SortFields.Clear
objList.Sort.SortFields.Add Key:=.Range(sListName & "[Personalnummer]"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
objList.Sort.SortFields.Add Key:=Range(sListName & "[Startdatum]"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With objList.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'Daten im Kalenderblatt eintragen
With objList.DataBodyRange
For Zei_D = 1 To .Rows.Count
Spa_K1 = 0: Spa_K2 = 0
'prüfen, ob neue Personal-Nummer
If varPersNr .Cells(Zei_D, 2).Value Then
varPersNr = .Cells(Zei_D, 2)
Zei_K = Zei_K + 1
' wksKal.Cells(Zei_K, 1) = varPersNr
wksKal.Cells(Zei_K, 1) = "'" & varPersNr 'Personal-Nr. als Text eintragen (mit fü _
hrenden Nullen)
End If
'Daten in Variablen einlesen
varSchicht = .Cells(Zei_D, 3).Value
datStart = .Cells(Zei_D, 4).Value
datEnde = .Cells(Zei_D, 5).Value
'prüfen, ob Datums-Werte im Bereich des Kalenders liegen
If datStart datEndeKal Then
Spa_K2 = Spa_KL
ElseIf datEnde >= datStartKal Then
Spa_K2 = SpaDatum1 + (datEnde - datStartKal)
End If
If Spa_K2 = 0 Or Spa_K1 = 0 Then
'außerhalb Datumsbereich
Else
'Schichtwert eintragen für Datumsbereich
With wksKal
.Range(.Cells(Zei_K, Spa_K1), .Cells(Zei_K, Spa_K2)).Value = varSchicht
End With
End If
Next
End With
End Sub