Zusammenführung von 2 Tabellen - komplex
24.01.2019 18:22:13
2
ich möchte gerne 2 Tabellen: Tabelle1 + Tabelle2 in Tabelle 3 zusammenführen. Die gewünschte Form könnt ihr der Beispielmappe entnehmen. Die Farben sind nur zur besseren Veranschaulichung gedacht.
https://www.herber.de/bbs/user/126977.xlsx
Nach kurzer Rücksprache mit "ChrisL", hat er mir empfohlen die Angelegenheit mit For-Next-Schleifen zu lösen. Da meine VBA-Kenntnisse relativ bescheiden sind, habe ich etwas Recherche betrieben und der unten angefügte Code kam heraus. Weniger überraschenderweise funktioniert er nicht.
Sub Zusammenführen()
Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Dim iZeile1 As Long, iZeile2 As Long, iZeile3 As Long
Dim letzteZeile As Long, merkeZeile As Long
Set WS1 = Worksheets("Tabelle1")
Set WS2 = Worksheets("Tabelle2")
Set WS3 = Worksheets("Tabelle3")
Application.ScreenUpdating = False
WS3.Rows("2:65536").Delete
With WS1
letzteZeile1 = .Cells(Rows.Count, 1).End(xlUp).Row
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & letzteZeile), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("B2:B" & letzteZeile), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:D" & letzteZeile)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With WS2
letzteZeile2 = .Cells(Rows.Count, 1).End(xlUp).Row
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & letzteZeile), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("B2:B" & letzteZeile), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:C" & letzteZeile)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For iZeile1 = 2 To letzteZeile
If .Cells(iZeile3, 1) .Cells(iZeile1 - 1, 1) Then 'neuer Block
iZeile3 = iZeile3 + 2
merkeZeile = iZeile3
WS3.Cells(iZeile3, 1) = WS1.Cells(iZeile1, 1)
With WS3.Range(WS3.Cells(iZeile3, 1), WS3.Cells(iZeile3, 5)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End If
For iZeile2 = 2 To letzteZeile
If .Cells(iZeile3, 1) .Cells(iZeile2 - 1, 1) Then 'neuer Block
iZeile3 = iZeile3 + 2
merkeZeile = iZeile3
WS3.Cells(iZeile3, 1) = WS2.Cells(iZeile2, 1)
With WS3.Range(WS3.Cells(iZeile3, 1), WS3.Cells(iZeile3, 5)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End If
If WS3.Cells(iZeile1, 1) = WS1.Cells(iZeile2, 1) & WS Then
WS3.Cells(iZeile3, 5) = WS3.Cells(iZeile3, 5) + WS2.Cells(iZeile2, 3)
Else 'neuer Datensatz in bestehenden Block
iZeile3 = iZeile3 + 1
WS3.Cells(iZeile3, 2) = .Cells(iZeile1, 2)
WS3.Cells(iZeile3, 3) = .Cells(iZeile1, 3)
WS3.Cells(iZeile3, 4) = .Cells(iZeile1, 4)
WS3.Cells(iZeile3, 5) = .Cells(iZeile2, 3)
End If
Next iZeile1
Next iZeile2
End With
End Sub
Ich würde mich freuen, wenn mir einer von euch VBA-Experten weiterhelfen könnte. Habe ehrlich gesagt keine Ahnung wie ich da vorgehen soll.
Besten Dank im Voraus!
