AW: Mehrere Tabellen zusammenführen
01.11.2017 17:10:26
Christian
hallo Kay,
hier mein Vorschlag:
... denn Onur überschreibt die Quell-Daten und Daniel hat 5 Datensätze vergessen...
Sind bei mir auch Fehler drin? Will ich nicht ausschließen - bitte testen.
Grüße
Christian
Option Explicit
Sub TestIt()
Dim i As Long, lngLR As Long
Dim objDic As Object
Dim strKey As String
Dim vntRes(), vntKey
Set objDic = CreateObject("SCripting.Dictionary")
With ThisWorkbook.Sheets("Daten")
For i = 3 To .Cells(.Rows.Count, 2).End(xlUp).Row
strKey = .Cells(i, 2) & "|" & .Cells(i, 3)
ReDim vntRes(11)
vntRes(0) = .Cells(i, 5) ' Spiele
vntRes(1) = .Cells(i, 4) ' Tore
vntRes(2) = .Cells(i, 6) ' Tore/Spiel
objDic(strKey) = vntRes
Next
For i = 3 To .Cells(.Rows.Count, 9).End(xlUp).Row
strKey = .Cells(i, 9) & "|" & .Cells(i, 10)
If objDic.Exists(strKey) Then
vntRes = objDic(strKey)
vntRes(3) = vntRes(3) + .Cells(i, 11) ' 7-Meter-Tore
vntRes(4) = vntRes(4) + .Cells(i, 12) ' 7-Meter-Versuche
vntRes(5) = vntRes(5) + .Cells(i, 13) ' 7-Meter-Trefferquote
objDic(strKey) = vntRes
Else
ReDim vntRes(11)
vntRes(3) = vntRes(3) + .Cells(i, 11) ' 7-Meter-Tore
vntRes(4) = vntRes(4) + .Cells(i, 12) ' 7-Meter-Versuche
vntRes(5) = vntRes(5) + .Cells(i, 13) ' 7-Meter-Trefferquote
objDic(strKey) = vntRes
End If
Next
For i = 3 To .Cells(.Rows.Count, 17).End(xlUp).Row
strKey = .Cells(i, 17) & "|" & .Cells(i, 18)
If objDic.Exists(strKey) Then
vntRes = objDic(strKey)
vntRes(6) = vntRes(6) + .Cells(i, 20) ' Gelbe-Karten
vntRes(7) = vntRes(7) + .Cells(i, 19) ' Gelbe-Karten/Spiel
objDic(strKey) = vntRes
Else
ReDim vntRes(11)
vntRes(0) = .Cells(i, 21) ' Spiele
vntRes(6) = .Cells(i, 20) ' Gelbe-Karten
vntRes(7) = .Cells(i, 19) ' Gelbe-Karten/Spiel
objDic(strKey) = vntRes
End If
Next
For i = 3 To .Cells(.Rows.Count, 34).End(xlUp).Row
strKey = .Cells(i, 34) & "|" & .Cells(i, 35)
If objDic.Exists(strKey) Then
vntRes = objDic(strKey)
vntRes(8) = vntRes(8) + .Cells(i, 37) ' Rote-Karten
vntRes(9) = vntRes(9) + .Cells(i, 36) ' Rote-Karten/Spiel
objDic(strKey) = vntRes
Else
ReDim vntRes(11)
vntRes(0) = .Cells(i, 38) ' Spiele
vntRes(8) = .Cells(i, 37) ' Rote-Karten
vntRes(9) = .Cells(i, 36) ' Rote-Karten/Spiel
objDic(strKey) = vntRes
End If
Next
For i = 3 To .Cells(.Rows.Count, 24).End(xlUp).Row
strKey = .Cells(i, 24) & "|" & .Cells(i, 25)
If objDic.Exists(strKey) Then
vntRes = objDic(strKey)
vntRes(10) = vntRes(10) + .Cells(i, 27) ' Zeitstrafen
vntRes(11) = vntRes(11) + .Cells(i, 26) ' Zeitstrafen/Spiel
objDic(strKey) = vntRes
Else
ReDim vntRes(11)
vntRes(0) = .Cells(i, 31) ' Spiele
vntRes(10) = .Cells(i, 27) ' Zeitstrafen
vntRes(11) = .Cells(i, 26) ' Zeitstrafen/Spiel
objDic(strKey) = vntRes
End If
Next
End With
i = 6
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Statistik")
lngLR = .Cells(.Rows.Count, 3).End(xlUp).Row
.Cells(6, 2).Resize(lngLR, 15).ClearContents
For Each vntKey In objDic.Keys
.Cells(i, 3).Resize(, 2) = Split(vntKey, "|")
.Cells(i, 5).Resize(, 12) = objDic(vntKey)
i = i + 1
Next
End With
Application.ScreenUpdating = True
Set objDic = Nothing
End Sub