ja, so geht es.
Nun zu dem Folgeproblem.
Code:
Option Explicit
'**************************************************
'* 27.02.2009 *
'* erstellt von RaBe *
'* erstellt Statistik über Tests sowie Diagramme *
'**************************************************
Public SW As Long
Dim Schritt As Double, Schritt1 As Double
Dim Länge As Double
Dim k As Long
Sub Statistik(Protokoll As String, Auswertung As String)
' Definition der Variablen
Dim Zelle, z%, a, b%, c1, c2, c3, c4, i%, j%, red As Integer
Dim SummeGrau%, SummeWeiss%, SummeWeissS%, SummeBlau%, SummeTuerkis%, SummeLavendel%, SummeGelb%
Dim SummeGruen%, SummeGruenW%, SummeGruenS%, GesamtsummeGruen%
Dim SummeRot%, SummeRotW%, SummeRotS%, GesamtsummeRot%
Dim Mon%, col%
Dim varFeld(2, 9) As Double
Dim intB As Integer
Dim S1 As String
Dim S2 As String
Dim Ist As String
' Bedeutung der Farben
' Grau, 15, Schraffiert, Prüfung nicht geplant ' Farbname, Farbnummer, Bedeutung der Farbe
' Blassblau , 37, Prüfung geplant
' Türkis , 8, Prüfung wird durchgeführt
' Lavendel , 39, Prüfung abgeschlossen, Bewertung fehlt
' Gelb , 6, Prüfung abgeschlossen, Abweichendes Ergebnis
' Grün , 4, Prüfung bestanden
' Rot , 3, Prüfung nicht bestanden
' Rot , 3, W, Prüfung nach Wiederholung nicht bestanden
' Grün , 4, W, Prüfung nach Wiederholung bestanden
' Löschen der Farbzähl-Variablen beim Start
SummeGruen = 0
SummeGruenW = 0
SummeGruenS = 0
GesamtsummeGruen = 0
SummeGelb = 0
SummeRot = 0
SummeRotW = 0
SummeRotS = 0
SummeGrau = 0
SummeWeiss = 0
SummeWeissS = 0
SummeBlau = 0
SummeTuerkis = 0
SummeLavendel = 0
' Definition des Array für die Auswertung und Diagramme (2x 6 =) 12 Test-Arten
For i = 0 To 5
For j = 0 To 2
varFeld(j, i) = 0
Next j
Next i
Mon = 0
col = 0
Application.ScreenUpdating = False ' speed up the macro durch ausschalten der stänbdigen Bildschirmaktualisierung
Worksheets(Protokoll).Activate
' ######################## Code für Fortschrittsanzeige
k = 0
' Anpassen an maximal benutzten Bereich über alle Übersichten!
SW = Range("L7:HR32").Cells.Count ' Gesamtlaufzeit festlegen über Zählbereich
Länge = 0
Schritt = PB1.Label1.Width / SW ' Schrittbreite pro Aktualisierung
' ######################## Code für Fortschrittsanzeige
' Bereich analog oben anpassen!
For Each Zelle In Range("L7:HR32") ' Tabellenbereich, der überprüft wird.
' ######################## Code für Fortschrittsanzeige
k = k + 1
Länge = Länge + Schritt
PB1.Label2.Width = Länge
PB1.Label3.Caption = Format(k / SW, "0 %")
DoEvents
' ######################## Code für Fortschrittsanzeige
a = Zelle.Column
b = Range(Cells(2, a), Cells(2, a)).Interior.ColorIndex
' ######################## Zählen der Farben
If b = 34 Then
Select Case Zelle.Interior.ColorIndex
Case 2, Is < 0 ' Farbe Weiss oder so
If Zelle.Interior.Pattern = xlLightUp Then
SummeWeissS = SummeWeissS + 1
Else
SummeWeiss = SummeWeiss + 1
End If
Case 3 ' Farbe Rot, abgeschlossen, Prüfung nicht bestanden
SummeRotS = SummeRotS + 1
If Zelle.Interior.Pattern <> xlUp Then
If Right(Zelle.Value, 1) = "W" Then ' Prüfung nach Wiederholung nicht bestanden
SummeRotW = SummeRotW + 1
Else
SummeRot = SummeRot + 1
End If
End If
Case 4 ' Farbe Grün, abgeschlossen, bestanden
SummeGruenS = SummeGruenS + 1
GesamtsummeGruen = GesamtsummeGruen + 1
If Zelle.Interior.Pattern <> xlUp Then
If Right(Zelle.Value, 1) = "W" Then
SummeGruenW = SummeGruenW + 1
Else
SummeGruen = SummeGruen + 1
End If
End If
Case 6 ' Farbe Gelb, Prüfung abgeschlossen, Abweichendes Ergebnis
SummeGelb = SummeGelb + 1
Case 15 ' Farbe Grau, Prüfung nicht geplant
SummeGrau = SummeGrau + 1
Case 37 ' Farbe Blau, Test geplant
SummeBlau = SummeBlau + 1
Case 8 ' Türkis, 8, Prüfung wird durchgeführt
SummeTuerkis = SummeTuerkis + 1
Case 39 ' Lavendel, Prüfung abgeschlossen, Bewertung fehlt
SummeLavendel = SummeLavendel + 1
End Select
End If
' hier wird geprüft, ob manche Tests nur für manche Requirement-Vorschriften benötigt werden!
Set c1 = Cells(3, Zelle.Column).Find("SDR", LookIn:=xlValues, LookAt:=xlPart)
Set c2 = Cells(3, Zelle.Column).Find("BDVR", LookIn:=xlValues, LookAt:=xlPart)
Set c3 = Cells(2, Zelle.Column).Find("Package drop", LookIn:=xlValues, LookAt:=xlPart)
Set c4 = Cells(2, Zelle.Column).Find("Handling Drop", LookIn:=xlValues, LookAt:=xlPart)
' wenn in Zeile 3 nirgends etwas drin steht, dann ist variable red mit 1 gefüllt
If ((c1 Is Nothing) And (Not c2 Is Nothing)) Or (Not c3 Is Nothing) Or (Not c4 Is Nothing) Then
red = 1
Else
red = 0
End If
Select Case Zelle.Interior.ColorIndex ' Zuweisung der Test-Art zu Variable intB
Case 3, 4, 6, 37, 39
Select Case Cells(4, Zelle.Column) ' Welcher Begriff steht in Zeile 4?
Case "Functional"
intB = 0
Case "Climatic"
intB = 1
Case "Mechanical"
intB = 2
Case "Corrosion"
intB = 3
Case "Electrical"
intB = 4
Case "IP"
intB = 5
Case "Endurance"
intB = 6
Case "Additional"
intB = 7
Case "Chemical"
intB = 8
Case "Safety"
intB = 9
Case Else ' falls etwas anderes oder nichts in Zelle steht!
intB = 99
End Select
' Übergabe der Zahlen an ein Array für die Test-Art
If intB < 99 Then
varFeld(0, intB) = varFeld(0, intB) + 1
If (Zelle.Interior.ColorIndex = 37) And (red > 0) Then ' Farbe Blau, Test geplant, Requirement
varFeld(1, intB) = varFeld(1, intB) + 1
ElseIf (Zelle.Interior.ColorIndex = 4) Then ' Farbe Grün, abgeschlossen, bestanden
varFeld(2, intB) = varFeld(2, intB) + 1
ElseIf (Zelle.Interior.ColorIndex = 8) Then ' Türkis , 8, Prüfung wird durchgeführt
varFeld(2, intB) = varFeld(2, intB) + 0.5
End If
End If
End Select
Next Zelle
' Definition der Spalten für den Eintrag der Monatszahlen
Select Case Cells(1, "D").Value
Case "Mai 2014"
Mon = 0
Case "Juni 2014"
Mon = 1
Case "Juli 2014"
Mon = 2
Case "August 2014"
Mon = 3
Case "September 2014"
Mon = 4
Case "Oktober 2014"
Mon = 5
Case "November 2014"
Mon = 6
Case "Dezember 2014"
Mon = 7
Case "Januar 2015"
Mon = 8
Case "Februar 2015"
Mon = 9
Case "März 2015"
Mon = 10
Case "April 2015"
Mon = 11
Case "Mai 2015"
Mon = 12
Case "Juni 2015"
Mon = 13
Case "Juli 2015"
Mon = 14
Case "August 2015"
Mon = 15
Case "September 2015"
Mon = 16
Case "Oktober 2015"
Mon = 17
Case "November 2015"
Mon = 18
Case "Dezember 2015"
Mon = 19
Case "Januar 2016"
Mon = 20
Case "Februar 2016"
Mon = 21
Case "März 2016"
Mon = 22
Case "April 2016"
Mon = 23
Case "Mai 2016"
Mon = 24
Case "Juni 2016"
Mon = 25
' Case <== hier weitere Bedingungen
End Select
col = Mon + 4 ' 4 + 12 + Mon - 10
' Monats-Status der Testzahlen übertragen
Worksheets(Auswertung).Cells(3, col).Value = varFeld(0, 0)
Worksheets(Auswertung).Cells(4, col).Value = varFeld(2, 0)
Worksheets(Auswertung).Cells(5, col).Value = varFeld(0, 1)
Worksheets(Auswertung).Cells(6, col).Value = varFeld(2, 1)
Worksheets(Auswertung).Cells(7, col).Value = varFeld(0, 2)
Worksheets(Auswertung).Cells(8, col).Value = varFeld(2, 2)
Worksheets(Auswertung).Cells(9, col).Value = varFeld(0, 3)
Worksheets(Auswertung).Cells(10, col).Value = varFeld(2, 3)
Worksheets(Auswertung).Cells(11, col).Value = varFeld(0, 4)
Worksheets(Auswertung).Cells(12, col).Value = varFeld(2, 4)
Worksheets(Auswertung).Cells(13, col).Value = varFeld(0, 5)
Worksheets(Auswertung).Cells(14, col).Value = varFeld(2, 5)
Worksheets(Auswertung).Cells(15, col).Value = varFeld(0, 6)
Worksheets(Auswertung).Cells(16, col).Value = varFeld(2, 6)
Worksheets(Auswertung).Cells(17, col).Value = varFeld(0, 7)
Worksheets(Auswertung).Cells(18, col).Value = varFeld(2, 7)
Worksheets(Auswertung).Cells(19, col).Value = varFeld(0, 8)
Worksheets(Auswertung).Cells(20, col).Value = varFeld(2, 8)
Worksheets(Auswertung).Cells(21, col).Value = varFeld(0, 9)
Worksheets(Auswertung).Cells(22, col).Value = varFeld(2, 9)
Application.ScreenUpdating = True
Call Datum_setzen
Worksheets(Auswertung).Activate
' ######################## Code für Fortschrittsanzeige
' Application.Wait (Now + TimeValue("0:00:1"))
Unload PB1
' ######################## Code für Fortschrittsanzeige
End Sub
Wie kann ich nun 8 oder 13 mal den Fortschrittsbalken aufrufen und dabei jeweils das Protokoll/Auswertungs-Namenspaar an das Statistikmodul übergeben?