AW: nutze doch die PIVOTauswertung ...
16.04.2016 21:28:28
Piet
Hallo Markus
anbei eine Marko Lösung, ıch hoffe sie funktioniert einwandfrei.
Hallo Werner,
Sorry das ich mich in den Thread mit eingeklinkt habe, ich kannte deine Antwort noch nicht.
Nachdem ich mir die Arbeit mit dem Makro gemacht hatte wollte ich es nicht in den Müll werfen.
Markus soll selbst entscheiden was er brauchen kann.
herzliche Grüsse an Euch
von Piet
Option Explicit '16.4.015 Piet für Herber Forum
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