Herbers Excel-Forum - das Archiv

Tabellen über ID berechnen

Bild

Betrifft: Tabellen über ID berechnen
von: Net Shark

Geschrieben am: 02.01.2007 11:27:25
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.
Bild

Betrifft: AW: Tabellen über ID berechnen
von: fcs

Geschrieben am: 02.01.2007 14:18:04
Hallo NetShark,
folgendes Makro sollte die gewünschte Funktion ausführen. Falls das 1. Blatt in die Berechnung des Durchschnitts mit einbezogen werden soll, dann müssen die als Bemerkung markierten Zeilen verwendet werden.
Gruß
Franz
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

Bild

Betrifft: AW: Tabellen über ID berechnen
von: Net Shark

Geschrieben am: 02.01.2007 16:04:40
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

Bild

Betrifft: AW: Tabellen über ID berechnen
von: fcs

Geschrieben am: 03.01.2007 08:18:11
Hallo NetShark,
so sollten die Spalten korrekt abgearbeitet werden
'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

Gruss
Franz
Bild

Betrifft: AW: Tabellen über ID berechnen
von: NetShark

Geschrieben am: 30.01.2007 12:54:44
Hallo,
jetzt habe ich noch eine anderes Problem:
ich möchte nachwievor nach den IDs in den Übrigen Worksheets suchen, diesmal will ich aber jeweils die Spalten B-S untereiander in eine Gesamtliste kopieren. Exel soll also über die IDs iterieren und sich jeweils die Daten aus den Sheets suchen und diese dann in ein Worksheet kopieren.
Bild

Betrifft: AW: Tabellen über ID berechnen
von: NetShark
Geschrieben am: 30.01.2007 13:23:13
Es natürlich noch um Excel2003 nicht 11.
 Bild
Excel-Beispiele zum Thema "Tabellen über ID berechnen"
Suche über mehrere Tabellen Benennen von Tabellenblättern mit Monatsnamen
Druckseitenlinien im Tabellenblatt Tabellenblattnamen in ein Listenfeld einlesen
Suchbegriff über mehrere Tabellenblätter suchen. Tabellenblätter benennen
Tabellenblatt auswählen Zustand von Tabellenblatt-Checkboxes ermitteln
Tabellenblattnamen der VBE-Projekte ändern Tabellenblattnamen nach Datum