Konsolidierung Version 2

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Michael
Leider ist die Frage nicht klar. Bitte erstelle ein paar Beispiele/Zeilen mehr und zeige konkret Ist- und Soll-Zustand auf.
Z.B. soll Zeile 3 nun konsolidiert oder gelöscht werden?
Im Beispiel sehe ich keine "Teile" von Textwerten. Wenn Zeilen gelöscht werden, werden die Filterwerte ebenfalls mit gelöscht? Wie stellst du dir das zusammenführen vor (Komma getrennt?).
Bitte auch darauf achten, dass die Beispieldatei soweit konkret ist, dass der Aufbau und die verwendeten Spalten etc. stimmen. Ansonsten wird es nachher ein hin und her bis du das Makro auf deine Datei angepasst hast.
Amazon-Gutschein ist zwar nett gemeint, aber das Forum basiert auf Freiwilligenarbeit. Wenn du am Ende des Tages mit deiner Lösung glücklich bist, dann kannst du gerne eine Spende an eine gemeinnützige Organisation deiner Wahl machen.
cu
Chris

Sub t() Dim WS1 As Worksheet, WS2 As Worksheet Dim iZeile As Long, MatchZeile As Long Set WS1 = Worksheets("Tabelle1") Set WS2 = Worksheets.Add WS1.Rows(1).Copy WS2.Rows(1) For iZeile = 2 To WS1.Cells(Rows.Count, 10).End(xlUp).Row If WorksheetFunction.CountIf(WS2.Columns(10), WS1.Cells(iZeile, 10)) = 0 Then WS1.Rows(iZeile).EntireRow.Copy WS2.Rows(WS2.Cells(Rows.Count, 10).End(xlUp).Row + 1) Else MatchZeile = Application.Match(WS1.Cells(iZeile, 10), WS2.Columns(10), 0) WS2.Cells(MatchZeile, 19) = WS2.Cells(MatchZeile, 19) & " " & WS1.Cells(iZeile, 19) End If Next iZeile End Sub

Hi Micha
So...

Sub t()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim iZeile As Long, iiZeile As Long, MatchZeile As Long
Set WS1 = Worksheets("Tabelle1")
Set WS2 = Worksheets.Add
Application.ScreenUpdating = False
WS1.Rows(1).Copy WS2.Rows(1)
For iZeile = 2 To WS1.Cells(Rows.Count, 10).End(xlUp).Row
If WorksheetFunction.CountIf(WS2.Columns(10), WS1.Cells(iZeile, 10)) = 0 Then
WS1.Rows(iZeile).EntireRow.Copy WS2.Rows(WS2.Cells(Rows.Count, 10).End(xlUp).Row + 1)
Else
MatchZeile = Application.Match(WS1.Cells(iZeile, 10), WS2.Columns(10), 0)
WS2.Cells(MatchZeile, 19) = WS2.Cells(MatchZeile, 19) & " " & WS1.Cells(iZeile, 19)
End If
Next iZeile
For iZeile = WS2.Cells(Rows.Count, 10).End(xlUp).Row To 2 Step -1
For iiZeile = 2 To WS1.Cells(Rows.Count, 20).End(xlUp).Row
If WS2.Cells(iZeile, 19) Like "*" & WS1.Cells(iiZeile, 20) & "*" Then
WS2.Rows(iZeile).EntireRow.Delete
Exit For
End If
Next iiZeile
Next iZeile
WS1.Columns(20).Copy WS2.Columns(20)
End Sub

cu
Chris

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread