Konsolidieren von Text

Text · 2018-01-03T11:04:04+00:00

Hallo zusammen, ich suche eine Möglichkeit um Zeilen mit Text auf Grundlage von 2 Vorbedingungen zu konsolidieren: [Bild: Userbild] • Schreibe alle Tätigkeiten einer Person, die sie an einem Datum erfüllt hat in eine Zelle mit Trennung "; " Im nächsten Schritt soll die Funktion per Kontrollkästchen aktivierbar sein, da die sie nur optional sein. Vielen Dank im Voraus! Jome

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

Hallo Jome,
sowie man die Zell-Texte mit "&" verketten kann, so kann man die Zahlen/Zeiten mit "+" addieren.
Falls die Zeiten/Zahlen als Text in der Tabelle "Overviev" stehen, dann muss ggf. noch Wert-Konversionen mit CDate oder CDbl durchführen
Entsprechende Code-Zeilen hab ich als Kommentar eingefügt.
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("Overview") 'Blattame ggf. anpassen
'Tabellenblatt mit den gruppierten Erggebnisdaten setzen
Set wksTaet = ActiveWorkbook.Worksheets("Ergebnis") 'Blattame ggf. anpassen
Application.ScreenUpdating = False
With wksTaet
.UsedRange.ClearContents
.Columns(1).NumberFormat = "DD.MM.YYYY"
'        .Columns(3).NumberFormat = "#,##0.00"  '  wenn Dauer als Dezimalzahl
.Columns(3).NumberFormat = "[h]:mm"     '  wenn Dauer als Uhrzeit
End With
With wksData
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
'Datumswerte in Spalte A kopieren
.Range(.Cells(22, 1), .Cells(Zeile_L, 1)).Copy
wksTaet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
'Datumswerte in Spalte F kopieren
.Range(.Cells(22, 6), .Cells(Zeile_L, 6)).Copy
wksTaet.Cells(1, 2).PasteSpecial Paste:=xlPasteValues
'Taetigkeiten in Spalte H kopieren
.Range(.Cells(22, 8), .Cells(Zeile_L, 8)).Copy
wksTaet.Cells(1, 4).PasteSpecial Paste:=xlPasteValues
'Stunden in Spalte K kopieren
.Range(.Cells(22, 11), .Cells(Zeile_L, 11)).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, 4))
.Sort Key1:=.Range("A1"), order1:=xlAscending, _
Key2:=.Range("B1"), order2:=xlAscending, _
Key3:=.Range("D1"), 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
If Not Zeile = 1 And Zeile

Forumthread: Konsolidieren von Text

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Infobox / Tutorial