AW: Konsolidieren von Text
03.01.2018 22:12:47
Text
Hallo Jome,
hier ein entsprechendes Makro.
Die Ergebnisdaten werden in einem anderen Tabellenblatt ausgegeben.
Gruß
Franz
Sub Taetigkeiten_zusammenfassen()
Dim wksData As Worksheet, wksTaet As Worksheet
Dim Zeile_L As Long
Dim Zeile As Long, Zeile1 As Long, varDatum, varMA, bolDelete As Boolean
'Tabellenblatt mit den Daten setzen
Set wksData = ActiveWorkbook.Worksheets("Daten") 'Blattame ggf. anpassen
'Tabellenblatt mit den gruppierten Erggebnisdaten setzen
Set wksTaet = ActiveWorkbook.Worksheets("Tätigkeiten") 'Blattame ggf. anpassen
Application.ScreenUpdating = False
With wksTaet
.UsedRange.ClearContents
.Columns(1).NumberFormat = "DD.MM.YYYY"
End With
With wksData
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
'Datumswerte in Spalte A kopieren
.Range(.Cells(1, 1), .Cells(Zeile_L, 1)).Copy
wksTaet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
'Datumswerte in Spalte F kopieren
.Range(.Cells(1, 6), .Cells(Zeile_L, 6)).Copy
wksTaet.Cells(1, 2).PasteSpecial Paste:=xlPasteValues
'Taetigkeiten in Spalte H kopieren
.Range(.Cells(1, 8), .Cells(Zeile_L, 8)).Copy
wksTaet.Cells(1, 3).PasteSpecial Paste:=xlPasteValues
End With
With wksTaet
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
'Daten sortieren
With .Range(.Cells(1, 1), .Cells(Zeile_L, 3))
.Sort Key1:=.Range("A1"), order1:=xlAscending, _
Key2:=.Range("B1"), order2:=xlAscending, _
Key3:=.Range("C1"), order3:=xlAscending, Header:=xlYes
End With
'Tätigkeiten von MA am Datum in jeweils 1. Zeile überragen
For Zeile = 1 To Zeile_L + 1
If varDatum .Cells(Zeile, 1) Or varMA .Cells(Zeile, 2) Then
'1. Zeile, MA-Name und Datum merken wenn Name oder Datum wechselt
Zeile1 = Zeile
varDatum = .Cells(Zeile, 1).Value
varMA = .Cells(Zeile, 2).Value
Else
'Tätigkeit in 1. Zeile in Spalte C hinzufügen
.Cells(Zeile1, 3).Value = _
.Cells(Zeile1, 3).Value & ";" & .Cells(Zeile, 3).Value
'Inhalt in Zeile löschen
.Rows(Zeile).ClearContents
bolDelete = True 'merken, dass gelöscht wurde
End If
Next
If bolDelete = True Then
'leere Zeilen löschen
With .Range(.Cells(1, 1), .Cells(Zeile_L, 1))
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlShiftUp
End With
End If
.Activate
.Range("A1").Select
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub
