Option Explicit
'#### A N P A S S E N ######################################
'Muster zur Review-Datei-Suche
Const c_Ziel_Speicherpfad = C:\Test\Review\Auswertung
Const c_DATEIMUSTER_REVIEWS = Review*.xls
Const c_Ziel_Dateiname = AuswRev_
Const c_Ziel_BltName = AuswRev_
'#### A N P A S S E N ######################################
Const c_BewKrit_K = 1
Const c_BewKrit_B = 2
Const c_BewKrit_F = 3
Const c_BewKrit_P = 4
Const c_BewKrit_O = 5
Const c_BewKrit_I = 6
Const c_BewKrit_andere = 7
Type myReviewAusw_structure
s_Verantwortlicher As String
BewKrit(1 To c_BewKrit_andere) As Long
End Type
'Blattbeschreibung Ziel
Const c_RevZ_Ueberschrift = 1
Const c_RevZ_ERSTEWERTEZEILE = c_RevZ_Ueberschrift + 1
Const c_RevSP_Verz = 1: Const c_RevSP_Verz_TXT = Verzeichnis
Const c_RevSP_Datei = 2: Const c_RevSP_Datei_TXT = Dateiname
Const c_RevSP_E10 = 3: Const c_RevSP_E10_TXT = E10
Const c_RevSP_G8 = 4: Const c_RevSP_G8_TXT = G8
Const c_RevSP_D5 = 5: Const c_RevSP_D5_TXT = D5
Const c_RevSP_H2 = 6: Const c_RevSP_H2_TXT = H2
Const c_RevSP_B3 = 7: Const c_RevSP_B3_TXT = B3
Const c_RevSP_D6 = 8: Const c_RevSP_D6_TXT = D6
Const c_RevSP_B29 = 9: Const c_RevSP_B29_TXT = B29
Const c_RevSP_C29 = 10: Const c_RevSP_C29_TXT = C29
Const c_RevSP_D29 = 11: Const c_RevSP_D29_TXT = D29
Const c_RevSP_E29 = 12: Const c_RevSP_E29_TXT = E29
Const c_RevSP_F29 = 13: Const c_RevSP_F29_TXT = F29
Const c_RevSP_G29 = 14: Const c_RevSP_G29_TXT = G29
Const c_RevSP_H29 = 15: Const c_RevSP_H29_TXT = H29
Const c_RevSP_Verantw = 16: Const c_RevSP_Verantw_TXT = Verantwortlich
Const c_RevSP_BewKrK = 17: Const c_RevSP_BewKrK_TXT = Bew.-Kr. K
Const c_RevSP_BewKrB = 18: Const c_RevSP_BewKrB_TXT = Bew.-Kr. B
Const c_RevSP_BewKrF = 19: Const c_RevSP_BewKrF_TXT = Bew.-Kr. F
Const c_RevSP_BewKrP = 20: Const c_RevSP_BewKrP_TXT = Bew.-Kr. P
Const c_RevSP_BewKrO = 21: Const c_RevSP_BewKrO_TXT = Bew.-Kr. O
Const c_RevSP_BewKrI = 22: Const c_RevSP_BewKrI_TXT = Bew.-Kr. I
Const c_RevSP_BewKrandere = 23: Const c_RevSP_BewKrandere_TXT = Bew.-Kr. andere
'Beschreibung der Quelldatei
Const c_QBlt_Daten = Datenblatt
Const c_QBlt_Review = Reviewprotokoll
Const c_Q_ERSTEWERTEZEILE = 5
Const c_QSP_BestZeilen = 5 ->Spalte E zur Bestimmung der letzten Zeile
Const c_QSP_BewKr = 6 'Spalte F
Const c_QSP_Verantw = 7 'Spalte G
Const c_QSP_SollDatum = 8 'Spalte H
Const c_QSP_IstDatum = 9 ->Spalte H
'************************************************************************************
'ich möchte eine Exeldatei erstellen die in bestimmten Verzeichnissen nach
'bestimmten Dateien (z.B. Review*.xls) sucht und hier bestimmte Zellen übernimmt.
'
'Es muss die möglichkeit bestehen die Suche mehrmals durchlaufen zu lassen.
'
'Such Verzeichnis und Dateinamen z.B.:
'Im Verzeichnis C:\Review\Review und allen Unterordnern
'nach Dateien der Form Review*.xls
'
'Die Übernommenen Zellen aus den Dateien:
'Datenblatt: H2,D5,B3,D6,E10,G8,B29: H29
'
'Reviewprotokoll:
'Hier wird es kompliziert:
'In der Spalte F stehen Bewertungskriterien (z.B.: K,B,F,P,O,I,...)
'In der Spalte G sind die Verantwortlichen
'In der Spalte H ist der gewünschte Erledigungsdatum
'In der Spalte I ist dann der Ist-Erledigungstermin
'
'Ich hätte jetzt gerne die offenen, also alle Felder der Spalte I gezählt in Abhängigkeiten der
'Bewertungskriterien und Verantwortlichen und dann Ausgegeben.
'
'Die Ausgabe DAtei könnte So aussehen:
'
'Verzeichnis Dateiname Inhalt E10
'Inhalt G8 Inhalt D5 Inhalt H2 Inhalt B3 Inhalt D6 Inhalte B29:H29
'Verantwortlich Bewertungskriterien K Bewertungskriterien B Bewertungskriterien F
'Bewertungskriterien P Bewertungskriterien O Bewertungskriterien I
'
Sub ReviewStatistikSammler()
Dim wba As Workbook, wsa As Worksheet
Dim wbq As Workbook, wsqd As Worksheet, wsqr As Worksheet
Dim wbz As Workbook, wsz As Worksheet
Dim f_Rev() As myFiles_structure, f_Rev_cnt As Long
Dim l_zz As Long, l_zq As Long, l_rev As Long
Dim s_Datum As String, s_ZieldateiName As String
Dim s_SuchPfad As String
->Eingabe des Suchpfades
s_SuchPfad = VerzeichnisAuswahl(Bitte wählen Sie den Suchpfad aus)
If s_SuchPfad = Then Exit Sub
Application.StatusBar = Dateien suchen
If Not ReviewFilesSuchen(s_SuchPfad, c_DATEIMUSTER_REVIEWS, f_Rev(), f_Rev_cnt) Then
MsgBox (Fehler bei Suche der Review-Files)
GoTo AUFRAEUMEN
End If
->aktives Arbeitsblatt merken
Set wba = ActiveWorkbook: Set wsa = ActiveSheet
->Bildschirm-Update abschalten
Application.ScreenUpdating = False
->Ziel-Mappe anlegen
Application.StatusBar = Ziel-Datei anlegen
Call ZielmappeAnlegen(wbz, wsz)
->nächste Wertezeile im Ziel
l_zz = c_RevZ_ERSTEWERTEZEILE
->Review-Mappen nacheinander bearbeiten
For l_rev = 1 To f_Rev_cnt
On Error Resume Next
->Datei Öffnen
Workbooks.Open FileName:=f_Rev(l_rev).s_VollerPafd
If Err.Number <> 0 Then
Err.Clear
MsgBox (Fehler beim Öffnen von & vbLf & f_Rev(l_rev).s_VollerPafd)
GoTo AUFRAEUMEN
End If
Set wbq = ActiveWorkbook
Set wsqd = wbq.Worksheets(c_QBlt_Daten)
If Err.Number <> 0 Then
Err.Clear
MsgBox (Blatt-> & c_QBlt_Daten &-> nicht vorhanden. & vbLf & f_Rev(l_rev).s_VollerPafd)
GoTo AUFRAEUMEN
End If
Set wsqr = wbq.Worksheets(c_QBlt_Review)
If Err.Number <> 0 Then
Err.Clear
MsgBox (Blatt-> & c_QBlt_Review &-> nicht vorhanden. & vbLf & f_Rev(l_rev).s_VollerPafd)
GoTo AUFRAEUMEN
End If
On Error GoTo 0
->Verarbeiten
Application.StatusBar = Ergebnis eintragen aus: & f_Rev(l_rev).s_Dateiname
Call ReviewVerarbeitenUndWerteInZieldateiEintragen(wsz, l_zz, wsqd, wsqr, wbq)
->Datei schliessen
wbq.Close Savechanges:=False
Next
->Ziel-Datei Restbearbeitung
Application.StatusBar = Ende-Bearbeitung der Zieldatei
->Nach Pfad, Dateiname, Verantwortlichem sortieren
wsz.UsedRange.Sort _
Key1:=wsz.Columns(c_RevSP_Verz), Order1:=xlAscending, _
Key1:=wsz.Columns(c_RevSP_Datei), Order1:=xlAscending, _
Key1:=wsz.Columns(c_RevSP_Verantw), Order1:=xlAscending, _
Header:=xlYes
->Spaltenbreite optimieren und Zoom 75%
wsz.UsedRange.EntireColumn.AutoFit
wsz.Activate: ActiveWindow.Zoom = 75
->Blattnamen vergeben
s_Datum = Format(Now(), yyyymmdd_hhnnss)
wsz.Name = c_Ziel_BltName & s_Datum
->Pagesetup
With wsz.PageSetup
.Orientation = xlLandscape ->xlPortrait->xlLandscape
.LeftHeader = &Arial,Fett&16 Marquardt
.CenterHeader = &Arial,Fett&12Auswertung der offenen Reviewpunkte
.RightHeader = Format(Now(), dd.mm.yyyy)
.LeftFooter = Ersteller: Sahin Duygun
.CenterFooter = &P / &N
.RightFooter = wbz.FullName & , & wsz.Name
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 150
End With
->Zieldatei speichern
On Error Resume Next
s_ZieldateiName = c_Ziel_Speicherpfad & Application.PathSeparator & c_Ziel_Dateiname & s_Datum & .xls
wbz.SaveAs FileName:=s_ZieldateiName
If Err.Number <> 0 Then
Err.Clear
MsgBox (Zieldatei konnte nicht gespeichert werden. & vbLf & s_ZieldateiName)
GoTo AUFRAEUMEN
Else
On Error GoTo 0
wbz.Close Savechanges:=False
Application.ScreenUpdating = True
MsgBox (Ergebnisfile: & s_ZieldateiName)
End If
AUFRAEUMEN:
Application.StatusBar =
On Error GoTo 0
wsa.Activate
Set wba = Nothing: Set wsa = Nothing
Set wbq = Nothing: Set wsqd = Nothing: Set wsqr = Nothing
Set wbz = Nothing: Set wsz = Nothing
End Sub
Private Function ReviewVerarbeitenUndWerteInZieldateiEintragen( _
wsz As Worksheet, l_zz As Long, wsqd As Worksheet, wsqr As Worksheet, wbq As Workbook)
Dim f_RevAw() As myReviewAusw_structure, f_RevAw_cnt As Long
Dim v As Long
->Rückgabefeld initialisieren
ReDim f_RevAw(1 To 1): f_RevAw_cnt = 0
Call ReviewBlattAuswerten(wsqr, f_RevAw(), f_RevAw_cnt)
For v = 1 To f_RevAw_cnt
->Pfad, Datei eintragen
wsz.Cells(l_zz, c_RevSP_Verz).Value = wbq.Path
wsz.Cells(l_zz, c_RevSP_Datei).Value = wbq.Name
->Werte aus Datenblatt eintragen
Call WerteAusDatenblattUebertragen(wsz, l_zz, wsqd)
->Werte aus Auswertung eintragen
With f_RevAw(v)
wsz.Cells(l_zz, c_RevSP_Verantw).Value = .s_Verantwortlicher
wsz.Cells(l_zz, c_RevSP_BewKrK).Value = .BewKrit(c_BewKrit_K)
wsz.Cells(l_zz, c_RevSP_BewKrB).Value = .BewKrit(c_BewKrit_B)
wsz.Cells(l_zz, c_RevSP_BewKrF).Value = .BewKrit(c_BewKrit_F)
wsz.Cells(l_zz, c_RevSP_BewKrP).Value = .BewKrit(c_BewKrit_P)
wsz.Cells(l_zz, c_RevSP_BewKrO).Value = .BewKrit(c_BewKrit_O)
wsz.Cells(l_zz, c_RevSP_BewKrI).Value = .BewKrit(c_BewKrit_I)
wsz.Cells(l_zz, c_RevSP_BewKrandere).Value = .BewKrit(c_BewKrit_andere)
End With
->nächste Zeile
l_zz = l_zz + 1
Next
End Function
Private Function ReviewBlattAuswerten(wsqr As Worksheet, f_RevAw() As myReviewAusw_structure, f_RevAw_cnt As Long)
Dim l_rows As Long, z As Long, v As Long, b_gefunden As Boolean
Dim s_Verantwortlicher As String, s_BewKriterium As String, l_BewKriterium As Long
->letzte Zeile feststellen
l_rows = wsqr.Cells(wsqr.Rows.Count, c_QSP_BestZeilen).End(xlUp).Row
->Alle Zeilen asuwerten
For z = c_Q_ERSTEWERTEZEILE To l_rows
->pruefen, Soll-Datum leer
If wsqr.Cells(z, c_QSP_IstDatum).Value = Then
s_Verantwortlicher = wsqr.Cells(z, c_QSP_Verantw).Value
s_BewKriterium = UCase(wsqr.Cells(z, c_QSP_BewKr).Value)
If s_BewKriterium = K Then
l_BewKriterium = c_BewKrit_K
ElseIf s_BewKriterium = B Then
l_BewKriterium = c_BewKrit_B
ElseIf s_BewKriterium = F Then
l_BewKriterium = c_BewKrit_F
ElseIf s_BewKriterium = P Then
l_BewKriterium = c_BewKrit_P
ElseIf s_BewKriterium = O Then
l_BewKriterium = c_BewKrit_O
ElseIf s_BewKriterium = I Then
l_BewKriterium = c_BewKrit_I
Else
l_BewKriterium = c_BewKrit_andere
End If
->Verantwortlichen in Auswertungs-Struktur suchen
b_gefunden = False
For v = 1 To f_RevAw_cnt
If s_Verantwortlicher = f_RevAw(v).s_Verantwortlicher Then
b_gefunden = True
->Kriterium zählen
f_RevAw(v).BewKrit(l_BewKriterium) = f_RevAw(v).BewKrit(l_BewKriterium) + 1
End If
Next
If Not b_gefunden Then
->neuen Verantwortlichen eintragen
f_RevAw_cnt = f_RevAw_cnt + 1: ReDim Preserve f_RevAw(1 To f_RevAw_cnt)
f_RevAw(f_RevAw_cnt).s_Verantwortlicher = s_Verantwortlicher
->Kriterium zählen
f_RevAw(v).BewKrit(l_BewKriterium) = 1
End If
End If
Next
End Function
Private Function WerteAusDatenblattUebertragen(wsz As Worksheet, l_zeile As Long, wsqd As Worksheet)
wsz.Cells(l_zeile, c_RevSP_E10).Value = wsqd.Range(E10).Value
wsz.Cells(l_zeile, c_RevSP_G8).Value = wsqd.Range(G8).Value
wsz.Cells(l_zeile, c_RevSP_D5).Value = wsqd.Range(D5).Value
wsz.Cells(l_zeile, c_RevSP_H2).Value = wsqd.Range(H2).Value
wsz.Cells(l_zeile, c_RevSP_B3).Value = wsqd.Range(B3).Value
wsz.Cells(l_zeile, c_RevSP_D6).Value = wsqd.Range(D6).Value
wsz.Cells(l_zeile, c_RevSP_B29).Value = wsqd.Range(B29).Value
wsz.Cells(l_zeile, c_RevSP_C29).Value = wsqd.Range(C29).Value
wsz.Cells(l_zeile, c_RevSP_D29).Value = wsqd.Range(D29).Value
wsz.Cells(l_zeile, c_RevSP_E29).Value = wsqd.Range(E29).Value
wsz.Cells(l_zeile, c_RevSP_F29).Value = wsqd.Range(F29).Value
wsz.Cells(l_zeile, c_RevSP_G29).Value = wsqd.Range(G29).Value
wsz.Cells(l_zeile, c_RevSP_H29).Value = wsqd.Range(H29).Value
End Function
Private Function ZielmappeAnlegen(wbz As Workbook, wsz As Worksheet)
Dim x As Long, z As Long
->Ziel-Mappe anlegen
Set wbz = Workbooks.Add
For x = wbz.Worksheets.Count To 2 Step -1
Application.DisplayAlerts = False
wbz.Worksheets(x).Delete
Application.DisplayAlerts = True
Next
Set wsz = wbz.Worksheets(1)
z = c_RevZ_Ueberschrift
With wsz.Cells(z, c_RevSP_Verz)
.Value = c_RevSP_Verz_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_Datei)
.Value = c_RevSP_Datei_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_E10)
.Value = c_RevSP_E10_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_G8)
.Value = c_RevSP_G8_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_D5)
.Value = c_RevSP_D5_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_H2)
.Value = c_RevSP_H2_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_B3)
.Value = c_RevSP_B3_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_D6)
.Value = c_RevSP_D6_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_B29)
.Value = c_RevSP_B29_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_C29)
.Value = c_RevSP_C29_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_D29)
.Value = c_RevSP_D29_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_E29)
.Value = c_RevSP_E29_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_F29)
.Value = c_RevSP_F29_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_G29)
.Value = c_RevSP_G29_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_H29)
.Value = c_RevSP_H29_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_Verantw)
.Value = c_RevSP_Verantw_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_BewKrK)
.Value = c_RevSP_BewKrK_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_BewKrB)
.Value = c_RevSP_BewKrB_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_BewKrF)
.Value = c_RevSP_BewKrF_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_BewKrP)
.Value = c_RevSP_BewKrP_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_BewKrO)
.Value = c_RevSP_BewKrO_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_BewKrI)
.Value = c_RevSP_BewKrI_TXT: .Font.Bold = True
End With
With wsz.Cells(z, c_RevSP_BewKrandere)
.Value = c_RevSP_BewKrandere_TXT: .Font.Bold = True
End With
End Function