mit RemoveDuplicates ...
19.11.2015 15:19:43
Matthias
Hallo
Soll am Ende also so aussehen?
Tabelle2
| | A | B |
| 1 | Liste | Tore |
| 2 | Lukas Heil | 2 |
| 3 | Lucas Unbehaun | 5 |
| 4 | Werner Wegendt | 10 |
| 5 | Jakob Kochim | 1 |
| 6 | Benjamin Panse | 1 |
| 7 | Nick Breiter | 2 |
| 8 | Marvin Correus | 5 |
| 9 | Sven Gruenwald | 6 |
| 10 | Leonard Tigler | 1 |
| 11 | Viktor Strak | 1 |
| 12 | Daniel Illenseer | 4 |
| 13 | Florian Koch | 1 |
| 14 | Thomas Luniger | 1 |
| 15 | Thomas Gruda | 1 |
| 16 | Fabien Berger | 18 |
| 17 | Marcel Stock | 3 |
Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Option Explicit
Sub zusammenfassen2()
Dim sp&, Loletzte&, x&, LoLetzte2&
Application.ScreenUpdating = False
With Tabelle2
.Columns("A:B").ClearContents
.Cells(1, 1) = "Liste"
.Cells(1, 2) = "Tore"
.Cells(1, 1).Font.Bold = True
.Cells(1, 2).Font.Bold = True
.Cells(1, 1).Interior.Color = vbYellow
.Cells(1, 2).Interior.Color = vbYellow
For sp = 2 To 16
Loletzte = Cells(Rows.Count, sp).End(xlUp).Row
For x = 1 To Loletzte
If Cells(x, sp) "" Then .Cells(LoLetzte2 + 1, 1) = Cells(x, sp)
LoLetzte2 = .Cells(Rows.Count, 1).End(xlUp).Row
Next
Next
.Select
End With
With Columns("A:B")
.EntireColumn.AutoFit
.RemoveDuplicates Columns:=1, Header:=xlYes
End With
Loletzte = Cells(Rows.Count, 1).End(xlUp).Row
With Range("B2")
.FormulaR1C1 = "=COUNTIF(Tabelle1!R4C2:R150C16,RC[-1])"
.AutoFill Destination:=Range("B2:B" & Loletzte)
End With
MsgBox "fertig", vbInformation
End Sub
Gruß Matthias