Tabellen über ID berechnen

Ich habe eine Exceldatei mit mehreren Worksheets. Das von mir gesuchte Makro soll nun aus dem ersten Worksheet sich die ID aus einer festen Spalte holen und im folgenden in jedem Worksheet nach dieser ID suchen. Aus der entsprechenden Zeile ist dann der Wert der Spalte K zu kopieren und auf die Variable Counter zu addieren um am Ende den Durchschnitt zu berechnen. Am Ende soll dann ein neues Worksheet erzeugt werden mit der ID und nebenstehend dem Durchschnittswert. Mir fehlt es an VBA-Kenntnissen um das entsprechend umzusetzen, habe aber schon einen Algorithmus entworfen:
i = Zaehle Anzahl gefüllter WS
Für jede ID aus WS(1), Spalte B Schleife
{
Für jeden WS(i) Schleife
{
Suche in WS(i) nach Zeile j, die ID enthält
CounterID = CounterID + WS(i).Zelle(K,j)
}
}
CounterID = CounterID/i
Erzeuge neuen WS("Ergebnis") und gebe Werte aus.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub ID_Mittelwerte() Dim wks1 As Worksheet, wksErgebnis As Worksheet, wks2 As Worksheet Dim Blatt(), ID, rngFinden As Range, ZeileErgebnis As Long Dim Anz As Integer, Zeilewks1 As Long, CounterID As Double Set wks1 = Worksheets(1) 'Blatt mit ID-Nummern ' ReDim Blatt(1 To ActiveWorkbook.Worksheets.Count, 0 To 1) ReDim Blatt(2 To ActiveWorkbook.Worksheets.Count, 0 To 1) 'Anzahl ausgefüllter Blätter ermitteln und Blätter kennzeichnen ' For i = 1 To ActiveWorkbook.Worksheets.Count For i = 2 To ActiveWorkbook.Worksheets.Count Blatt(i, 0) = Worksheets(i).Name If Application.WorksheetFunction.CountA(Worksheets(i).Cells) > 0 Then Anz = Anz + 1 Blatt(i, 1) = True Else Blatt(i, 1) = False End If Next 'Blatt für Ergebnisse einfügen Worksheets.Add After:=Worksheets(ActiveWorkbook.Worksheets.Count) Set wksErgebnis = ActiveSheet wksErgebnis.Name = "Ergebnis" ZeileErgebnis = 1 wksErgebnis.Cells(ZeileErgebnis, "A") = "ID" wksErgebnis.Cells(ZeileErgebnis, "B") = "Durchschnitt" 'ID werte aus Blatt 1 in den anderen Blättern suchen und Mittelwerte im Blatt Ergebnis eintragen For Zeilewks1 = 1 To wks1.Cells(wks1.Rows.Count, "B").End(xlUp).Row ID = wks1.Cells(Zeilewks1, "B") CounterID = 0 ZeileErgebnis = ZeileErgebnis + 1 ' For i = 1 To ActiveWorkbook.Worksheets.Count - 1 For i = 2 To ActiveWorkbook.Worksheets.Count - 1 If Blatt(i, 1) = True Then 'Nur ausgefüllte Blätter berücksichtigen Set wks2 = Worksheets(Blatt(i, 0)) Set rngFinden = wks2.Cells.Find(What:=ID, LookIn:=xlValues, Lookat:=xlWhole) If Not rngFinden Is Nothing Then CounterID = CounterID + wks2.Cells(rngFinden.Row, "K") End If End If Next wksErgebnis.Cells(ZeileErgebnis, "A") = ID wksErgebnis.Cells(ZeileErgebnis, "B") = CounterID / Anz Next End Sub

Hallo Franz, vielen Dank für Dein Makro! Es lief gleich, ohne dass ich noch irgendwelche Anpassungen machen musste.
Ich habe es jetzt noch um 2 Punkte erweitert:
zum einen werden die Werte der Spalte S noch einmal in das Endergebniss mit eingefügt, was auch funktioniert.
Dann möchte ich noch überprüfen, ob es einen Leistungseinbruch zwischen zwei Werten gibt, allerdings bleibt das Makro ohne Wirkung... Falls die Bedingung erfüllt ist, soll die Zelle eingefärbt werden. Ich bin sicher, der Fehler ist nur klein, aber ich komme trotzdem nicht drauf.
Hier das modifizierte Makro


Sub ID_Mittelwerte()
Dim wks1 As Worksheet, wksErgebnis As Worksheet, wks2 As Worksheet, wks3 As Worksheet
Dim Blatt(), ID, rngFinden As Range, ZeileErgebnis As Long
Dim Anz As Integer, Zeilewks1 As Long, CounterID As Double
Set wks1 = Worksheets(1) 'Blatt mit ID-Nummern
ReDim Blatt(2 To ActiveWorkbook.Worksheets.Count, 0 To 1)
'Anzahl ausgefüllter Blätter ermitteln und Blätter kennzeichnen
For i = 2 To ActiveWorkbook.Worksheets.Count
Blatt(i, 0) = Worksheets(i).Name
If Application.WorksheetFunction.CountA(Worksheets(i).Cells) > 0 Then
Anz = Anz + 1
Blatt(i, 1) = True
Else
Blatt(i, 1) = False
End If
Next
'Blatt für Ergebnisse einfügen
Worksheets.Add After:=Worksheets(ActiveWorkbook.Worksheets.Count)
Set wksErgebnis = ActiveSheet
wksErgebnis.Name = "Ergebnis"
ZeileErgebnis = 1
wksErgebnis.Cells(ZeileErgebnis, "A") = "ID"
wksErgebnis.Cells(ZeileErgebnis, "B") = "Durchschnitt"
'ID werte aus Blatt 1 in den anderen Blättern suchen und Mittelwerte im Blatt Ergebnis eintragen
For Zeilewks1 = 4 To wks1.Cells(wks1.Rows.Count, "B").End(xlUp).Row
ID = wks1.Cells(Zeilewks1, "B")
CounterID = 0
ZeileErgebnis = ZeileErgebnis + 1
For i = 2 To ActiveWorkbook.Worksheets.Count - 1
If Blatt(i, 1) = True Then 'Nur ausgefüllte Blätter berücksichtigen
Set wks2 = Worksheets(Blatt(i, 0))
Set rngFinden = wks2.Cells.Find(What:=ID, LookIn:=xlValues, Lookat:=xlWhole)
If Not rngFinden Is Nothing Then
Hilf = wks2.Cells(rngFinden.Row, "S")
CounterID = CounterID + Hilf
'in Ergebnis alle Gesamtwerte der Wochen nach Tool Kopieren
wksErgebnis.Cells(ZeileErgebnis, i + 1) = Hilf
wksErgebnis.Cells(ZeileErgebnis, i + 1).NumberFormat = "0%"
End If
End If
Next
wksErgebnis.Cells(ZeileErgebnis, "A") = ID
wksErgebnis.Cells(ZeileErgebnis, "B") = CounterID / Anz
wksErgebnis.Cells(ZeileErgebnis, "B").NumberFormat = "0%"
Next
'Zellen hervorheben, wenn Leistungseinbruch gegenüber Vorgänger um 5%
Set wks3 = Worksheets("Ergebnis")
For ZeileErg = 2 To wks3.Cells(wks3.Rows.Count, "A").End(xlUp).Row
For SpalteErg = 3 To wks3.Cells(wks3.Columns.Count - 1, 3)
If ((wks3.Cells(ZeileErg, SpalteErg)) - (wks3.Cells(ZeileErg, SpalteErg + 1)) > 0.05) Then
wks3.Cells(ZeileErg, SpalteErg).ColorIndex = 45
End If
Next
Next
End Sub

'Zellen hervorheben, wenn Leistungseinbruch gegenüber Vorgänger um 5% Set wks3 = Worksheets("Ergebnis") For ZeileErg = 2 To wks3.Cells(wks3.Rows.Count, "A").End(xlUp).Row For SpalteErg = 3 To wks3.Cells(3, wks3.Columns.Count).End(xlToLeft).Column-1 If ((wks3.Cells(ZeileErg, SpalteErg)) - (wks3.Cells(ZeileErg, SpalteErg + 1)) > 0.05) Then wks3.Cells(ZeileErg, SpalteErg).ColorIndex = 45 End If Next Next End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread