AW: Tage aus Spalte in eine Zelle
27.02.2014 16:32:51
UweD
Hallo
hilft dir das?
Sub Sortieren()
On Error GoTo Fehler
Dim TB1, TB2, i&, j&, Monat%, Jahr%, NName$
Dim SP%, ZE&, LR1&, LR2&
Dim stCalc%
'*** bescheunigt das Makro
With Application
.ScreenUpdating = False
stCalc = .Calculation
.Calculation = xlCalculationManual
End With
'*** Stammdaten Anfang
Set TB1 = Sheets("Tabelle1")
Set TB2 = Sheets("Tabelle2")
SP = 2 'Spalte B
ZE = 2 'ab Zeile
Jahr = Year(Date)
'*** Stammdaten Ende
LR1 = TB1.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
'*** Die eigentliche Routine
TB2.Cells.ClearContents
With TB2
'*** sortieren Name, Datum
TB1.Sort.SortFields.Clear
TB1.Sort.SortFields.Add Key:=Range("B:B") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
TB1.Sort.SortFields.Add Key:=Range("A:A") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With TB1.Sort
.SetRange Range("A:C")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
TB1.Columns("B:B").Copy .Range("A1")
.Columns(1).RemoveDuplicates Columns:=1
For i = 1 To 12
.Cells(1, i + 1).Formula = DateSerial(Jahr, i, 1)
.Cells(1, i + 1).NumberFormat = "mmmm"
Next
j = 2
For i = ZE To LR1
Monat = Month(TB1.Cells(i, 1))
NName = TB1.Cells(i, 2)
If NName = .Cells(j, 1) Then
.Cells(j, Monat + 1) = .Cells(j, Monat + 1) & Format(Day(TB1.Cells(i, 1)), " _
00") & ", "
Else
i = i - 1
j = j + 1
End If
Next
End With
'*** Fehlerbehandlung
Err.Clear
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err. _
Clear
'*** Rücksetzen
With Application
.ScreenUpdating = True
If .Calculation stCalc Then .Calculation = stCalc
End With
End Sub
Gruß UweD