Werte geordnet zusammenfassen im Tabellenblatt
20.04.2016 18:45:05
Markus
Wie müsste ich den folgenden Code anpassen, wenn ich die Zuordnung der Werte nur in einem Tabellenblatt durchführen will. Die Zuordnung findet im Ausgangstabellenblatt (Tabelle 1) statt und ersetzt den alten Ausgangszustand; also ID, Projekt und Name sollen weiterhin nur in den Spalten A-C stehen und darunter die nun richtig sortieren Werte.
Der Code stammt von "Piet" (hier aus dem Forum, danke nochmal) und funktioniert einwandfrei. Damals waren es 3 Tabellenblätter, welche im 4.Tabellenblatt zusammengefasst werden.
Option Explicit
Dim Tab4 As Object, ZAdr As String
Dim Edr As String, SEdr As String
Dim zr As Long, lz As Long, z As Long
Dim a As Long, n As Long, j As Long
Sub Werte_kopieren_zusammenfassen()
Set Tab4 = Worksheets("Tabelle4")
zr = Tab4.Cells.Rows.Count
'alte Tabelle komplett löchen (Delete)
Tab4.Range("A2:B" & zr).Delete Shift:=xlUp
'Tabelle 1-3 Spalte A-B kopieren
For j = 1 To 3
ZAdr = Tab4.Cells(zr, 1).End(xlUp).Address
With Worksheets("Tabelle" & j)
lz = .Range("A1").End(xlDown).Row
.Range("A2:B" & lz).Copy
Tab4.Range(ZAdr).Offset(1, 0).PasteSpecial xlPasteAll
End With
Next j
Application.CutCopyMode = False
'Tzabelle 4 Spalte A alle zentrieren
Edr = Tab4.Cells(zr, 1).End(xlUp).Address
Tab4.Range("A2", Edr).HorizontalAlignment = xlCenter
'Tzabelle 4 Spalte A + B sortieren
SEdr = Tab4.Cells(zr, 2).End(xlUp).Address
Tab4.Range("A2", SEdr).Sort Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal
'letzte Zelle in Tabelle4 suchen
lz = Tab4.Cells(zr, 1).End(xlUp).Row
z = 2 '1. Zeile zum zusammenfassen
'Do Schleife zum zusammenfassen
Do Until z = lz + 1
a = z: n = 1 'Bereich ermitteln
If Cells(z, 1) = Cells(z + 1, 1) Then
For j = z To lz
If Cells(j, 1) = Cells(j + 1, 1) Then _
n = n + 1: z = z + 1 Else Exit For
Next j
End If
'Zellen in Spalte A verbinden
If n > 1 Then
Cells(a + 1, 1).Resize(n - 1, 1) = Empty
With Cells(a, 1).Resize(n, 1)
.VerticalAlignment = xlCenter
.MergeCells = True
End With
End If
'letzte Zelle unterstreichen
With Cells(z, 1).Resize(1, 2).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'naechste Zelle setzen
z = z + 1
Loop
End Sub
hier das Beispiel:
https://www.herber.de/bbs/user/105122.xlsx
Vielen Dank.