Ich würde gern in einem anderen Tabellenblatt eine Rangliste
erstellen. Und zwar dachte ich das ich z.B. in A1 von Hand
z.B. „Job1dauer“ eingebe. In B1 soll dann folgendes
widergegeben werden. Wenn in deinem Beispiel in B2:B4 ein Wert
>0 ist, dann soll der entsprechende Eintrag aus A plus die
entsprechenden Jahre aus B angezeigt werden. Also z.B. „Müller
8, Schulz 3“. Mit WennDann bekomme ich bei 79 Namen nicht
genügend Verschachtelungen hin und wenn ich einen Bereich
angebe, funktioniert es auch nicht.
Hi Frank,
ausgehend von Tabelle1
name jd1 jd2 jd3 jd4
müller 3 1 3 15
schulze 5 0 0 3
schmidt 0 12 8 6
bohlen 2 3 4 3
erhälst du Tabelle2
jobdauer1 schulze 5, müller 3, bohlen 2
jobdauer2 schmidt 12, bohlen 3, müller 1
jobdauer3 schmidt 8, bohlen 4, müller 3
jobdauer4 müller 15, schmidt 6, bohlen 3, schulze 3
wenn du das nachfolgende Makro ausführst. Überschriften werden automatisch übernommen, musst nur in den ersten Zeilen des Codes die Anzahl der Jobs (JobAnz) und ggf die Namen der drei Tabellen anpassen. Auch die Anzahl der Namen wird automatisch ermittelt, falls es mal keine 79 sind.
Der Code gehört in ein Modul, also Alt+F11, im VB-Editor Einfügen–Modul, F7, reinkopieren, Vb-Editor schliessen.
Gruß
Reinhard
Sub job()
JobAnz = 4
Set ws1 = Worksheets("Tabelle1")
Set ws2 = Worksheets("Tabelle2")
Set ws3 = Worksheets("Tabelle3")
ws2.UsedRange.Clear
ws1.Activate
letzte = Range("A65536").End(xlUp).Row 'letzte nichtleere Zelle in A
ws1.Range(Cells(1, 1), Cells(letzte, 1 + JobAnz)).Copy Destination:=ws3.Range("A1")
For n = 1 To JobAnz
ws3.Activate
ws3.Range(Cells(2, 1), Cells(letzte, 1 + JobAnz)).Select
Selection.Sort Key1:=ws3.Cells(2, 1 + n), Order1:=xlDescending, Key2:=ws3.Cells(2, 1) \_
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:= \_
False, Orientation:=xlTopToBottom
m = 2
While ws3.Cells(m, 1 + n) 0 And ws3.Cells(m, 1 + n) ""
ws2.Cells(n + 1, 2) = ws2.Cells(n + 1, 2) & " " & ws3.Cells(m, 1) & " " & ws3.Cells(m, n + 1) & ","
m = m + 1
Wend
If Len(ws2.Cells(n + 1, 2)) \> 1 Then 'letztes Komma raus
ws2.Cells(n + 1, 2) = Left(ws2.Cells(n + 1, 2), Len(ws2.Cells(n + 1, 2)) - 1)
End If
ws3.Cells(1, 1 + n).Copy Destination:=ws2.Cells(n + 1, 1)
Next n
ws3.UsedRange.Clear
ws2.Activate
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
End Sub