|
Hallo zusammen,
habe folgendes Problem, der Code ist im Anhang.
Dieses Makro zieht mehrere Excel-Dateien zum Vergleich aus den jeweiligen Unterordner, die alle in einem Ordner gebündelt sind.
Bislang funktioniert es auch durch die Auswahl "Alle" im Excel-File alle hintereinander automatisch einzulesen.
Nun hat sich eine Änderung ergeben, sodass mit "Alle" nur noch bestimmte Dateien und damit Buchungskreise ausgewählt werden sollen.
Daher scheitere ich jetzt daran nur bestimmte Buchungskreise auszuwählen (z.B. 2090 und 3030) über die Funktion "Alle", dabei soll jedoch die Funktion einen einzelnen Buchungskreis auszuwählen erhalten bleiben.
Vielen Dank
VG
Option Explicit
' bei Umstellung auf das neue Format von Office 2007 ändern auf ".xlsm"
Global Const cSuffix = ".xls"
'Startzeilen in den Arbeitsblättern
Global Const cRowOffsetProcess = 10 'Startzeile
Global Const cRowOffsetEinzelsätze = 3 'Startzeile für Einzelsätze
Global Const cRowOffsetSummary = 2
Global Const cRowOffsetReport = 77 'Startzeile in den VV-Berichten (zu prüfenden Excel-Dateien)
' Spalten in den VV-Berichten (zu prüfenden Excel-Dateien)
Global Const cColumnBestand = 6 'Spalte Bestand
'******************************
Public Sub doProcess()
'Deklaration
Dim tThisWorkbook As Object
Dim tWorksheetProcess As Worksheet
Dim tWorksheetLOG As Worksheet, tWorksheetLOG2 As Worksheet
Dim tWorksheetEinzelsätze As Worksheet
Dim tWorksheetSummary As Worksheet
Dim tWorksheetReport As Worksheet 'zu prüfendes Blatt
Dim tsRootDir As String, tsWorkDir As String, tsFullPath As String
Dim tsBuchungskreis As String 'Buchungskreis
Dim tsVerzeichnisName As String, vname2 As String 'Langtext Buchungskreis (wie Verzeichnis)
Dim tsReportType As String 'Variable für Zu-/Abgangsliste oder Bestandsliste
Dim tsReportName As String 'Report im Verzeichnis
Dim tVerzeichniseBuchungskreis() 'Array für die Buchungskreisverzeichnisse
Dim tExcelReports() 'Array für VV-Reports im PrüftPfad
Dim dvz(1 To 500, 1 To 10) 'Array für das zu erstellende DV-Z
Dim AppExcel As Object
Dim tsVermögensverzeichnis As String 'Vermögensverzeichnis
Dim tsUnterabteilung As String 'Unterabteilung
Dim tsVermögensstock As String 'Vermögensstock
Dim tRow As Long
Dim tRowSummary As Long
Dim tRowReport As Long
Dim tRowEinzelsätze As Long
Dim tLastRow As Long
Dim tRowLog2 As Long
Dim i As Integer 'Hilfsvariablen
Dim tiCounterDirectory As Integer, tiCounterReport As Integer, tiCounterWorksheet As Integer
Dim tiEmptyRow As Integer
Dim z2 As Integer 'Hilfsvariable
Dim ESB As Double 'Betrag für Einzelsätze
Dim ESNr As String 'Kennummer für Einzelsatzliste
Dim suchstr1, suchstr2 As String 'Suchfelder
Dim VerarbeitungEinzelbuchungskreis As Boolean 'Einzelbuchungskreis
Dim tsKeyVV As String ' Schlüssel Vermögensverzeichnis (Buchungskreis, Vermögensverzeichnis, Unterabteilung)
Dim tsAmountGroup As String
Dim tvCellValue As Variant
Dim tCellValue As Double 'temp für Zellwerte im Datentyp Doubble
Dim tZwSumme As Double
Dim tdZugang As Double 'Wert Zugänge
Dim tdAbgang As Double 'Wert Abgänge
Dim tSumme As Double 'Errechnete Summe
Dim tSummeZugang As Double 'Summe Zugänge
Dim tSummeAbgang As Double 'Summe Abgänge
Dim tSummeBestand As Double 'Summe Bestand
Dim tSummeBestandEuro As Double
Dim tSummeZuganguab As Double, tSummeZuganguabEuro As Double
Dim tDiff As Double 'Differenzwert
Dim dvzz As Integer 'Zeile im "DV-Z"
Dim IsInArray As Boolean 'Zeile im Array schon vorhanden
Dim IsPartnerGelöscht As Boolean 'Kennzeichen für gelöschte Partner
Dim IsBestandNegativ As Boolean 'Kennzeichen, ob negative Bestände (Nennwerte) vorhanden sind
Dim IsBuchwertNegativ As Boolean 'Kennzeichen, ob negative Buchwerte vorhanden sind
Dim IsBestandOhneBuchwert As Boolean 'Kennzeichen, ob negative Buchwerte vorhanden sind
Dim tDatum As String 'Datumsfeld
Dim tsMsg As String
Dim flagProcess As Boolean
Dim flagBREAK As Boolean
Dim flagVortrag As Boolean
'Initialisierung
Set tWorksheetProcess = ActiveWorkbook.Worksheets("Prüfung")
Set tWorksheetSummary = ActiveWorkbook.Worksheets("Zusammenfassung")
Set tWorksheetEinzelsätze = ActiveWorkbook.Worksheets("Einzelsätze")
Set tWorksheetLOG = ActiveWorkbook.Worksheets("Log")
Set tWorksheetLOG2 = ActiveWorkbook.Worksheets("Log2")
writeLog "Initalisierung"
tsVerzeichnisName = ""
VerarbeitungEinzelbuchungskreis = False
dvzz = 1 'Startzeile im DV-Z Array
'welches Arbeitsblatt??
tWorksheetProcess.Range("C10:K500").ClearContents
tWorksheetSummary.Range("A2:K500").ClearContents
Range(tWorksheetEinzelsätze.Cells(3, 1), tWorksheetEinzelsätze.Cells(50000, 7)).ClearContents
'initalisierung des LOG-Sheets
Range(tWorksheetLOG.Cells(1, 1), tWorksheetLOG.Cells(500000, 5)).ClearContents
tWorksheetLOG.Cells(1, 2) = 2
Range(tWorksheetLOG2.Cells(1, 3), tWorksheetLOG2.Cells(500000, 4)).ClearContents
tRowLog2 = 2
tWorksheetProcess.Cells(2, 6) = "Differenzenprüfung gestartet ..."
With tWorksheetProcess
'Anfang Verarbeitung
.Cells(4, 12) = Time
' Übernahme der Vorgabewerte
tsBuchungskreis = .Cells(3, 4)
tsRootDir = .Cells(4, 4)
tDatum = .Cells(5, 4)
'Aufbau der "Statusanzeige" für die Verarbeitung
.Cells(7, 4) = "Bestand"
.Cells(7, 5) = "Zu-/Abgang"
.Cells(7, 6) = "Differenz"
.Cells(7, 7) = "VV"
.Cells(7, 8) = "Uabt"
' .Cells(7, 9) = "Vermögensart"
.Cells(7, 10) = "Bestand/Bewegung"
.Cells(7, 111) = "Blatt"
'Verarbeitung eines vorgegebenen Buchungskreis
If tsBuchungskreis = "" Then
MsgBox "Es wurde kein Buchungskreis ausgewählt!"
Exit Sub
Else
If tsBuchungskreis = "A" Then
VerarbeitungEinzelbuchungskreis = False
Else
VerarbeitungEinzelbuchungskreis = True
End If
End If
End With
'Verarbeitung aller Buchungskreise
' Startzeile für die Ausgabe in den Arbeitsblättern
tRow = cRowOffsetProcess
tRowSummary = cRowOffsetSummary
tRowEinzelsätze = cRowOffsetEinzelsätze
' Einlesen der Verzeichnisse der tWorksheetReport Verzeichnisse
tiCounterDirectory = 0
tsVerzeichnisName = Dir(tsRootDir, vbDirectory)
'**********
'Übertragen der Verzeichnisnamen für die Buchungskreise in ein Array
' bis alle Verzeichnisse übernommen oder
' bei Verarbeitung eines einzelnen Buchungskreises das Verzeichnis im Zugriff
Do Until tsVerzeichnisName = "" Or Left$(tsVerzeichnisName, 4) = tsBuchungskreis
tsVerzeichnisName = Dir
If tsVerzeichnisName <> "." And tsVerzeichnisName <> ".." Then
'Bitweiser Vergleich
If (GetAttr(tsRootDir & tsVerzeichnisName) And vbDirectory) = vbDirectory Then
tiCounterDirectory = tiCounterDirectory + 1
ReDim Preserve tVerzeichniseBuchungskreis(tiCounterDirectory)
tVerzeichniseBuchungskreis(tiCounterDirectory) = tsVerzeichnisName
End If
End If
Loop
'16.02.09:jgr:ergänzt
For i = 1 To tiCounterDirectory
ActiveWorkbook.Worksheets("Log3").Cells(i + 1, 3) = tVerzeichniseBuchungskreis(i)
Next i
writeLog "Anzahl BK (Counter): ", CDbl(tiCounterDirectory)
writeLog "Anzahl BK (UBound): ", UBound(tVerzeichniseBuchungskreis)
'**********
' = (1) ========================================
' Verarbeitung über die Anzahl der Buchungskreisverzeichnisse
' loop directory (Buchungskreise)
For tiCounterDirectory = 1 To UBound(tVerzeichniseBuchungskreis)
'Initialisierung
tSummeBestand = 0
'Vorgabewert Buchungskreis prüfen
If VerarbeitungEinzelbuchungskreis Then
tsBuchungskreis = Left(tsVerzeichnisName, 4)
Else
'der Buchungskreis steht als 4stelliger Code am Anfang des Verzeichnisnamen
tsBuchungskreis = Left(tVerzeichniseBuchungskreis(tiCounterDirectory), 4)
tsVerzeichnisName = tVerzeichniseBuchungskreis(tiCounterDirectory)
End If
'Prüfen, ob Buchungskreis überhaupt DV-Verzeichnisse hat
tsWorkDir = tsRootDir & tsVerzeichnisName & "\"
tiCounterReport = 0
tsReportName = Dir(tsWorkDir, vbDirectory)
' = (2/1) ========================================
' liest alle Report-/Dateinamen für den Buchungkskreis (innerhalb des Verzeichnisses) in ein Array
' loop files (Excel-Report Dateien)
Do While tsReportName <> ""
tsReportName = Dir
If Left(tsReportName, 9) = "REPORT_VV" And Right(tsReportName, 12) = tDatum & cSuffix Then
tiCounterReport = tiCounterReport + 1
ReDim Preserve tExcelReports(tiCounterReport)
tExcelReports(tiCounterReport) = tsReportName
End If
'16.02.09:jgr:ergänzt
For i = 1 To tiCounterReport
ActiveWorkbook.Worksheets("Log3").Cells(i + 1, 4) = tExcelReports(i)
Next i
Loop ' = (2/1) =
'wenn Vermögensverzeichnisse vorliegen
If tiCounterReport > 0 Then
writeLog "Verarbeitung Vermögensverzeichnis -- Anzahl (CounterReport):", CDbl(tiCounterReport)
' = (2/2) ========================================
' Verarbeitung der jeweiligen Reportdatei
' 16.02.09:jgr: hier stand tiCounterReport = 10
' es gibt gerade keine Erklärung, warum die ersten 9 Einträge ausgelasen wurden
For tiCounterReport = 1 To UBound(tExcelReports)
'## gesteuerter Abbruch über Eingabe
'-----------------------------------
DoEvents
If Worksheets("Prüfung").lstProcess = "STOP" Then
tWorksheetProcess.Activate
tWorksheetProcess.Range("F2") = "!!! PRÜFUNG ABBGEBROCHEN !!!"
DoEvents
MsgBox "STOP-Befehl in Auswahl!" & vbCrLf & "Verarbeitung abgebrochen!", vbInformation + vbOKOnly, "VV-Prüfung"
Exit Sub
End If
'# Kennzeichnung von
' - Vermögensverzeichnis, Unterabteilung, Vermögensstock und Berichtsart
' aus dem Dateinamen der Excel-Datei raustrennen
tsVermögensverzeichnis = Mid(tExcelReports(tiCounterReport), 10, 2)
If Mid(tExcelReports(tiCounterReport), 1, 11) = "REPORT_VV09" Then
tsUnterabteilung = Mid(tExcelReports(tiCounterReport), 15, 2)
Else
tsUnterabteilung = Mid(tExcelReports(tiCounterReport), 14, 2)
End If
' ## Vermögensstock ermitteln
' If Mid(tExcelReports(tiCounterReport), 17, 2) = "DS" Then
' tsVermögensstock = "1"
' Else
' tsVermögensstock = "2"
' End If
' ## Berichtsart ermitteln
' Select Case tsVermögensstock
' Case "1"
If Mid(tExcelReports(tiCounterReport), 1, 11) = "REPORT_VV09" Then
If Mid(tExcelReports(tiCounterReport), 18, 13) = "BESTANDSLISTE" Then
tsReportType = "Bestand"
Else
tsReportType = "Zu-/Abgang"
End If
Else
If Mid(tExcelReports(tiCounterReport), 17, 13) = "BESTANDSLISTE" Then
tsReportType = "Bestand"
Else
tsReportType = "Zu-/Abgang"
End If
End If
' Case "2"
' If Mid(tExcelReports(tiCounterReport), 30, 13) = "BESTANDSLISTE" Then
' tsReportType = "Bestand"
' Else
' tsReportType = "Zu-/Abgang"
' End If
' End Select
With tWorksheetProcess
' Kennzeichen des geprüften Berichts anzeigen
.Cells(4, 6) = tsBuchungskreis
.Cells(8, 7) = tsVermögensverzeichnis
.Cells(8, 8) = tsUnterabteilung
' .Cells(8, 9) = tsVermögensstock
.Cells(8, 10) = tsReportType
End With
tsReportName = tExcelReports(tiCounterReport)
tsFullPath = tsWorkDir & tsReportName
tsKeyVV = "'" & tsBuchungskreis & "-" & tsVermögensverzeichnis & "-" & tsUnterabteilung
'Verwendung einer eigenen Instanz um das 'Flackern' der Fenster zu unterbinden
Set AppExcel = CreateObject("Excel.Application")
'** Excel-Berichtsdatei öffnen
AppExcel.Workbooks.Open tsFullPath, 0, True
writeLog "OPEN: " & tsFullPath
writeLog "Counter Sheets: ", AppExcel.Workbooks(tsReportName).Worksheets.Count, tsKeyVV
' = (3) ========================================
' über alle Arbeitsblätter der Report-Datei
For tiCounterWorksheet = 1 To AppExcel.Workbooks(tsReportName).Worksheets.Count
IsPartnerGelöscht = False
IsBestandNegativ = False
IsBuchwertNegativ = False
IsBestandOhneBuchwert = False
tiEmptyRow = 0 '28.09.08:jgr: Initalisierung ergänzt
Set tWorksheetReport = AppExcel.Workbooks(tsReportName).Worksheets(tiCounterWorksheet)
writeLog "Sheet: " & tWorksheetReport.Name & " (Nr: " & tiCounterWorksheet & ")"
' ********** getLastRow() **********
tLastRow = cRowOffsetReport
' = (4/1) ==
'Zeilennummer der letzten Datenreihe in einer Folge ermitteln
flagProcess = True
Do While flagProcess
'Abbruchbedingung für weitere Verarbeitung
If tWorksheetReport.Cells(tLastRow, 1) <> "" Then
If Left(CStr(tWorksheetReport.Cells(tLastRow, 1)), 22) = "Gesamt-Anrechnungswert" _
Or Left(CStr(tWorksheetReport.Cells(tLastRow, 1)), 46) = "Übertrag aus dem Vorjahr: (Anrechnungswert) 1)" _
Or Left(CStr(tWorksheetReport.Cells(tLastRow, 1)), 46) = "Übertrag aus dem Vorjahr (Anrechnungswert): 1)" Then
flagProcess = False
End If
End If
'Abbruch wenn keine RegNr vorhanden
If Trim(tWorksheetReport.Range("RegNr")) = "" Then
writeLog "BREAK PROCESSING!! Keine RegNr vorhanden und damit keine Werte", , tsKeyVV
flagProcess = False
tLastRow = 1
flagBREAK = True
End If
'* Abbruch bei mehr als 15 Leerzeilen in Folge
'*----------
If tiEmptyRow > 15 Then
writeLog "BREAK PROCESSING!! Mehr als 15 Leerzeilen in Folge", , tsKeyVV
tLastRow = 1
flagProcess = False
flagBREAK = True
End If
If tWorksheetReport.Cells(tLastRow, 1) = "" Then
tiEmptyRow = tiEmptyRow + 1
Else
tiEmptyRow = 1
End If
'* Abbruch bei evtl. Fehlern
'*----------
DoEvents
If tLastRow >= 100000 Then
Debug.Print "BREAK PROCESSING!!"
writeLog "BREAK PROCESSING!! Zähler größer 100.000", , tsKeyVV
tLastRow = 1
flagProcess = False
flagBREAK = True
End If
'*----------
tLastRow = tLastRow + 1
Loop ' = (4/1) == ermitteln der letzten Zeile
'Rückgabe der Zeilennummer
tLastRow = tLastRow - 1
' ********** END getLastRow() **********
If Not flagBREAK Then
writeLog tsReportType
flagVortrag = False
Select Case tsReportType
'********************
Case "Bestand"
tWorksheetProcess.Cells(4, 9) = tWorksheetReport.Cells(22, 7) 'Listendatum
tRowReport = cRowOffsetReport
' = (4/2) ==
' Zeilenweise Auswertung des Arbeitsblattes
For tRowReport = cRowOffsetReport To tLastRow - 1
If InStr(1, tWorksheetReport.Cells(tRowReport, 3), "lösch") <> 0 Then
IsPartnerGelöscht = True
End If
If InStr(1, tWorksheetReport.Cells(tRowReport, 3), "deaktiviert") <> 0 Then
IsPartnerGelöscht = True
End If
If tWorksheetReport.Cells(tRowReport, 9) <> 0 And tWorksheetReport.Cells(tRowReport, 9) < 0 Then
IsBestandNegativ = True ' Nennwert
End If
If tWorksheetReport.Cells(tRowReport, 6) <> 0 And tWorksheetReport.Cells(tRowReport, 6) < 0 Then
IsBuchwertNegativ = True ' Buchwert
End If
If Left(tWorksheetReport.Cells(tRowReport, 1), 7) <> "Bestand" Then
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 6))
writeLog "Zelle (Spalte/Zeile) 6/" & tRowReport & " (Bestand): ", tCellValue, tsKeyVV
If tCellValue <> 0 Then
tZwSumme = tSumme + tCellValue
tSumme = tZwSumme
End If
If Not IsNumeric(tSumme) Then
MsgBox "Summe nicht numerisch"
End If
'Ausgabe der Summe in Übersicht
tWorksheetProcess.Cells(8, 4) = tSumme
writeLog " Summe (Bestand): ", tSumme
If CDbl(tWorksheetReport.Cells(tRowReport, 6)) <> 0 Then
ESB = CDbl(tWorksheetReport.Cells(tRowReport, 6))
z2 = tRowReport
Do Until tWorksheetReport.Cells(z2, 3) = ""
z2 = z2 + 1
Loop
ESNr = tWorksheetReport.Cells(z2 - 1, 3)
With tWorksheetEinzelsätze
.Cells(tRowEinzelsätze, 1) = ESNr
.Cells(tRowEinzelsätze, 2) = ESB
.Cells(tRowEinzelsätze, 3) = tsVermögensstock
.Cells(tRowEinzelsätze, 4) = tWorksheetReport.Name
.Cells(tRowEinzelsätze, 5) = tsVermögensverzeichnis
.Cells(tRowEinzelsätze, 6) = tsUnterabteilung
.Cells(tRowEinzelsätze, 7) = tsBuchungskreis
End With
tRowEinzelsätze = tRowEinzelsätze + 1
'11.03.2009:jgr:ergänzt
Else
If CDbl(tWorksheetReport.Cells(tRowReport, 9)) <> 0 Then
writeLog "Nennwert (Bestand) ohne Buchwert (Bestand)"
IsBestandOhneBuchwert = True
'Stop
End If
End If
Else
tRowReport = tRowReport + 1 'nur 1 da einer über next
End If
Next tRowReport
'Differenzberechnung
'die Summenzahl kann in unterschiedlichen Spalten liegen ...
tSummeBestand = 0
writeLog "Zelle (Spalte/Zeile) 6/" & tRowReport & " (Differenzberechnung): >" & tWorksheetReport.Cells(tRowReport, 1) & "<"
For i = 3 To 6
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, i))
writeLog "Zelle (Spalte/Zeile) " & i & "/" & tRowReport & ": ", tCellValue, tsKeyVV
If tCellValue <> 0 Then
tZwSumme = tSummeBestand + tCellValue
tSummeBestand = tZwSumme
End If
Next i
writeLog "Differenzber. SummeBestand: ", tSummeBestand
'Prüfung, ob zusätzlich in Fremdwährung
If Left(CStr(tWorksheetReport.Cells(tRowReport, 1)), 22) = "Gesamt-Anrechnungswert" _
And InStr(CStr(tWorksheetReport.Cells(tRowReport, 1)), "EUR") = 0 Then
tSummeBestandEuro = CDbl(tWorksheetReport.Cells(tRowReport + 2, 3)) _
+ CDbl(tWorksheetReport.Cells(tRowReport + 2, 4)) _
+ CDbl(tWorksheetReport.Cells(tRowReport + 2, 5)) _
+ CDbl(tWorksheetReport.Cells(tRowReport + 2, 6))
Else
tSummeBestandEuro = tSummeBestand
End If
tZwSumme = tSumme - tSummeBestand
tDiff = tZwSumme
IsInArray = False
If tSummeBestand <> 0 Then
For i = 1 To 500
If dvz(i, 1) = tsBuchungskreis And dvz(i, 2) = tsVermögensverzeichnis _
And dvz(i, 3) = tsUnterabteilung And dvz(i, 4) = tsVermögensstock _
And dvz(i, 5) = tWorksheetReport.Name Then
dvz(i, 6) = tSummeBestand
dvz(i, 9) = tSummeBestandEuro
IsInArray = True
Exit For
End If
Next i
If IsInArray = False Then
dvz(dvzz, 1) = tsBuchungskreis
dvz(dvzz, 2) = tsVermögensverzeichnis
dvz(dvzz, 3) = tsUnterabteilung
dvz(dvzz, 4) = tsVermögensstock
dvz(dvzz, 5) = tWorksheetReport.Name
dvz(dvzz, 6) = tSummeBestand
dvz(dvzz, 9) = tSummeBestandEuro
dvzz = dvzz + 1
End If
End If
'********************
Case "Zu-/Abgang"
tWorksheetProcess.Cells(4, 9) = tWorksheetReport.Cells(22, 7) 'Listendatum
tRowReport = cRowOffsetReport
For tRowReport = cRowOffsetReport To tLastRow - 1 ' letzte Zeile ("Gesamt") wird nach Schleife verarbeitet
If InStr(1, tWorksheetReport.Cells(tRowReport, 2), "summenmäßige") <> 0 Then
tCellValue = CDbl(Trim(Right(tWorksheetReport.Cells(tRowReport, 2), 15)))
If tCellValue <> 0 Then
tZwSumme = tSumme - tCellValue
tSumme = tZwSumme
End If
Else
If InStr(1, tWorksheetReport.Cells(tRowReport, 3), "lösch") <> 0 Then
IsPartnerGelöscht = True
End If
If InStr(1, tWorksheetReport.Cells(tRowReport, 3), "deaktiviert") <> 0 Then
IsPartnerGelöscht = True
End If
If tWorksheetReport.Cells(tRowReport, 9) < -0.01 Then
IsBestandNegativ = True ' Nennwert
End If
If tWorksheetReport.Cells(tRowReport, 6) < -0.01 Then
IsBuchwertNegativ = True ' Buchwert
End If
' wenn kein Vortrag
'If InStr(1, tWorksheetReport.Cells(tRowReport, 1), "Vortrag") = 0 Then
tvCellValue = tWorksheetReport.Cells(tRowReport, 1)
If tvCellValue = "" Then
tsAmountGroup = ""
Else
If InStr(1, tvCellValue, "Übertrag") > 0 Then
tsAmountGroup = "Übertrag"
ElseIf InStr(1, tvCellValue, "Bestand Vortrag") > 0 Then
tsAmountGroup = "Vortrag"
flagVortrag = True
ElseIf Left(tvCellValue, 8) = "Zugänge:" Then
'tsAmountGroup = "Zugänge"
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
tdZugang = tCellValue
ElseIf Left(tvCellValue, 8) = "Abgänge:" Then
'tsAmountGroup = "Abgänge"
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
'If tCellValue <> 0 Then Stop
tdAbgang = tCellValue
ElseIf Left(tvCellValue, 25) = "Saldo Zu-/Abschreibungen:" Then
tsAmountGroup = "Saldo Zu-/Abschreibungen"
ElseIf Left(tvCellValue, 40) = "Saldo Zu-/Abschreibungen gem. §341c HGB:" Then
tsAmountGroup = "Saldo Zu-/Abschreibungen"
ElseIf InStr(1, tvCellValue, "Gesamt") > 0 Then
tsAmountGroup = "Gesamt"
Else
' wenn der Eintrag für die Zuordnung 'Vortrag' noch nicht vorgekommen ist, handelt es sich bei den Einträgen um Zu- und Abgänge
If flagVortrag = False Then
tsAmountGroup = "Zugang/Abgang"
Else
tsAmountGroup = "-"
End If
End If
End If
Select Case tsAmountGroup
Case "Übertrag", "Zugang/Abgang"
' Zugang (Spalte 4)
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
writeLog "Zelle (Spalte/Zeile) 4/" & tRowReport & " (Zugang):", tCellValue, tsKeyVV
tSumme = tSumme + tCellValue
' Abgang (Spalte 5)
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 5))
writeLog "Zelle (Spalte/Zeile) 5/" & tRowReport & " (Abgang):", tCellValue, tsKeyVV
tSumme = tSumme - tCellValue
tZwSumme = tSummeAbgang + tCellValue
tSummeAbgang = tZwSumme
'
If InStr(1, tWorksheetReport.Cells(tRowReport, 1), "Vorjahr") = 0 Then
' wenn NICHT Vorjahr
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
tZwSumme = tSummeZugang + tCellValue
tSummeZugang = tZwSumme
End If
'Ausgabe der Summe in Übersicht
tWorksheetProcess.Cells(8, 5) = tSumme
writeLog "Summe (" & tsAmountGroup & "):", tSumme
writeLog "Summe (Zugang):", tSummeZugang
writeLog "Summe (Abgang):", tSummeAbgang
Case "Saldo Zu-/Abschreibungen"
writeLog tsAmountGroup & ":"
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
writeLog "Zelle (Spalte/Zeile) 4," & tRowReport & " :", tCellValue
If tCellValue <> 0 Then
tZwSumme = tSumme + tCellValue
tSumme = tZwSumme
End If
End Select
End If
Next tRowReport
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
writeLog "Zelle (Spalte/Zeile) 4/" & tRowReport & " (Gesamt):", tCellValue, tsKeyVV
'Differenzberechnung
tSummeZuganguab = CDbl(tWorksheetReport.Cells(tRowReport, 4))
'Prüfung, ob zusätzlich in Fremdwährung
If Left(CStr(tWorksheetReport.Cells(tRowReport, 1)), 22) = "Gesamt-Anrechnungswert" And InStr(CStr(tWorksheetReport.Cells(tRowReport, 1)), "EUR") = 0 Then
tSummeZuganguabEuro = CDbl(tWorksheetReport.Cells(tRowReport + 2, 3)) + CDbl(tWorksheetReport.Cells(tRowReport + 2, 4)) + CDbl(tWorksheetReport.Cells(tRowReport + 2, 5)) + CDbl(tWorksheetReport.Cells(tRowReport + 2, 6))
Else
tSummeZuganguabEuro = tSummeZuganguab
End If
'Differenz aus Summe - Buchwert(Zugang)
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
tZwSumme = tSumme - tCellValue
tDiff = tZwSumme
IsInArray = False
'# Protokollierung von Unregelmässigkeiten
If Round(tSummeZugang, 2) - Round(tdZugang, 2) <> 0 Then
With tWorksheetProcess
.Cells(tRow, 3) = "Differenz im Buchungskreis " & tsBuchungskreis & " bei den Zugängen in Höhe von "
.Cells(tRow, 6) = tSummeZugang - tdZugang
.Cells(tRow, 7) = tsVermögensverzeichnis
.Cells(tRow, 8) = tsUnterabteilung
.Cells(tRow, 9) = tsVermögensstock
.Cells(tRow, 10) = tsReportType
.Cells(tRow, 11) = tWorksheetReport.Name
writeLog .Cells(tRow, 3), .Cells(tRow, 6)
End With
tRow = tRow + 1
End If
If Round(tSummeAbgang, 2) + Round(tdAbgang, 2) <> 0 Then
With tWorksheetProcess
.Cells(tRow, 3) = "Differenz im Buchungskreis " & tsBuchungskreis & " bei den Abgängen in Höhe von "
.Cells(tRow, 6) = tSummeAbgang + tdAbgang
.Cells(tRow, 7) = tsVermögensverzeichnis
.Cells(tRow, 8) = tsUnterabteilung
.Cells(tRow, 9) = tsVermögensstock
.Cells(tRow, 10) = tsReportType
.Cells(tRow, 11) = tWorksheetReport.Name
writeLog .Cells(tRow, 3), .Cells(tRow, 6)
End With
tRow = tRow + 1
End If
If tSummeZuganguab <> 0 Then
For i = 1 To 500
If dvz(i, 1) = tsBuchungskreis And dvz(i, 2) = tsVermögensverzeichnis And dvz(i, 3) = tsUnterabteilung And dvz(i, 4) = tsVermögensstock And dvz(i, 5) = tWorksheetReport.Name Then
dvz(i, 7) = tSummeZuganguab
dvz(i, 10) = tSummeZuganguabEuro
IsInArray = True
Exit For
End If
Next i
If Not IsInArray Then
dvz(dvzz, 1) = tsBuchungskreis
dvz(dvzz, 2) = tsVermögensverzeichnis
dvz(dvzz, 3) = tsUnterabteilung
dvz(dvzz, 4) = tsVermögensstock
dvz(dvzz, 5) = tWorksheetReport.Name
dvz(dvzz, 7) = tSummeZuganguab
dvz(dvzz, 10) = tSummeZuganguabEuro
dvzz = dvzz + 1
End If
End If
End Select
'** ------
End If
' If tsReportName = "REPORT_VV11_U01_DS_ZU_UND_ABGANG_20080930.xls" Then
' Debug.Print "x"
' End If
With tWorksheetProcess
'Ergebnis schreiben, wenn Differenz mehr als Rundung
If tDiff > 1 Or tDiff < -1 Then
.Cells(tRow, 3) = "Differenz im Buchungskreis " & tsBuchungskreis & " in Höhe von "
.Cells(tRow, 6) = tDiff
.Cells(tRow, 7) = tsVermögensverzeichnis
.Cells(tRow, 8) = tsUnterabteilung
.Cells(tRow, 9) = tsVermögensstock
.Cells(tRow, 10) = tsReportType
.Cells(tRow, 11) = tWorksheetReport.Name
tRow = tRow + 1
End If
tSumme = 0
tSummeZugang = 0
tSummeAbgang = 0
tsMsg = "Im Buchungskreis " & tsBuchungskreis & " im Vermögensverzeichnis " & tsVermögensverzeichnis & ", Uabt " & tsUnterabteilung & ", Sparte " & tWorksheetReport.Name
If IsPartnerGelöscht = True Then
.Cells(tRow, 3) = tsMsg & " befinden sich höchstwahrscheinlich gelöschte Partner! (" & tsReportType & ")"
tRow = tRow + 1
IsPartnerGelöscht = False
End If
If IsBestandNegativ = True Then
.Cells(tRow, 3) = tsMsg & " befinden sich negative Nominalbestände! (" & tsReportType & ")"
tRow = tRow + 1
IsBestandNegativ = False
End If
If IsBuchwertNegativ = True Then
.Cells(tRow, 3) = tsMsg & " befinden sich negative Buchwerte! (" & tsReportType & ")"
tRow = tRow + 1
IsBuchwertNegativ = False
End If
If IsBestandOhneBuchwert = True Then
.Cells(tRow, 3) = tsMsg & " befinden sich Nennwerte ohne Buchwerte! (" & tsReportType & ")"
tRow = tRow + 1
IsBuchwertNegativ = False
End If
End With
'28.09.08:jgr:ergänzt
If flagBREAK = True Then
tWorksheetLOG2.Cells(tRowLog2, 3) = "Verarbeitung ABGEBROCHEN ! BuKr:" & tsBuchungskreis & ", VV:" & tsVermögensverzeichnis & ", Uabt:" & tsUnterabteilung & ", VS:" & tsVermögensstock & ", Type:" & tsReportType
tWorksheetLOG2.Cells(tRowLog2, 4) = tsReportName
tRowLog2 = tRowLog2 + 1
flagBREAK = False
End If
Next tiCounterWorksheet
AppExcel.Workbooks(tsReportName).Close SaveChanges:=False
Next tiCounterReport
Else
tsMsg = "Der Buchungskreis " & tsBuchungskreis & " hat keine Vermögensverzeichnisse (oder nicht zum eingegebenen Datum)!"
tWorksheetProcess.Cells(tRow, 3) = tsMsg
tRow = tRow + 1
End If
If VerarbeitungEinzelbuchungskreis Then
Exit For
End If
Next tiCounterDirectory
'Ausgabe der Werte als "Zusammenfassung"
With tWorksheetSummary
For i = 1 To 500
If dvz(i, 1) <> "" Then
'wegen der Kopfzeile (Spaltenüberschrift, Werte immer eine Zeile 'tiefer' (+1) schreiben
.Cells(i + 1, 1) = dvz(i, 1)
.Cells(i + 1, 2) = dvz(i, 2)
.Cells(i + 1, 3) = dvz(i, 3)
.Cells(i + 1, 4) = dvz(i, 4)
.Cells(i + 1, 5) = dvz(i, 5)
.Cells(i + 1, 6) = dvz(i, 6) ' Bestand Whg
.Cells(i + 1, 7) = dvz(i, 7) ' Zu-/Abgang Whg
.Cells(i + 1, 8) = dvz(i, 6) - dvz(i, 7) ' Differenz Whg
.Cells(i + 1, 9) = dvz(i, 9) ' Bestand €
.Cells(i + 1, 10) = dvz(i, 10) ' Zu-/Abgang €
.Cells(i + 1, 11) = dvz(i, 9) - dvz(i, 10) ' Differenz €
End If
Next i
End With
tWorksheetProcess.Cells(2, 6) = "Differenzenprüfung abgeschlossen!"
writeLog "Differenzenprüfung abgeschlossen!"
'Ende Verarbeitung
tWorksheetProcess.Cells(4, 13) = Time
End Sub
'******************************
Public Function writeLog(pMsg As String, Optional pSumme As Double, Optional pZuordnung)
'******************************
Dim tRow As Long
tRow = CLng(ActiveWorkbook.Worksheets("LOG").Cells(1, 2)) + 1
ActiveWorkbook.Worksheets("LOG").Cells(tRow, 2) = Time
ActiveWorkbook.Worksheets("LOG").Cells(tRow, 3) = pMsg
If pSumme > 0 Then
ActiveWorkbook.Worksheets("LOG").Cells(tRow, 4) = pSumme
End If
ActiveWorkbook.Worksheets("LOG").Cells(tRow, 5) = pZuordnung
ActiveWorkbook.Worksheets("LOG").Cells(1, 2) = tRow
End Function
'******************************
Private Sub cmdProcess_Click()
'******************************
Dim tMsg As String, tAnswer As Integer
If Range("D3") = "A" Then
tMsg = "Prüfung wird über alle Solvency-I-Buchungskreise durchgeführt!"
tAnswer = MsgBox(tMsg, vbExclamation + vbOKCancel, "VV-Prüffung")
If tAnswer = vbOK Then
flagProcess = True
Else
flagProcess = False
End If
Else
flagProcess = True
End If
If flagProcess Then
Call doProcess1
End If
End Sub
Option Explicit
' bei Umstellung auf das neue Format von Office 2007 ändern auf ".xlsm"
Global Const cSuffix = ".xls"
'Startzeilen in den Arbeitsblättern
Global Const cRowOffsetProcess = 10 'Startzeile
Global Const cRowOffsetEinzelsätze = 3 'Startzeile für Einzelsätze
Global Const cRowOffsetSummary = 2
Global Const cRowOffsetReport = 77 'Startzeile in den VV-Berichten (zu prüfenden Excel-Dateien)
' Spalten in den VV-Berichten (zu prüfenden Excel-Dateien)
Global Const cColumnBestand = 6 'Spalte Bestand
'******************************
Public Sub doProcess()
'Deklaration
Dim tThisWorkbook As Object
Dim tWorksheetProcess As Worksheet
Dim tWorksheetLOG As Worksheet, tWorksheetLOG2 As Worksheet
Dim tWorksheetEinzelsätze As Worksheet
Dim tWorksheetSummary As Worksheet
Dim tWorksheetReport As Worksheet 'zu prüfendes Blatt
Dim tsRootDir As String, tsWorkDir As String, tsFullPath As String
Dim tsBuchungskreis As String 'Buchungskreis
Dim tsVerzeichnisName As String, vname2 As String 'Langtext Buchungskreis (wie Verzeichnis)
Dim tsReportType As String 'Variable für Zu-/Abgangsliste oder Bestandsliste
Dim tsReportName As String 'Report im Verzeichnis
Dim tVerzeichniseBuchungskreis() 'Array für die Buchungskreisverzeichnisse
Dim tExcelReports() 'Array für VV-Reports im PrüftPfad
Dim dvz(1 To 500, 1 To 10) 'Array für das zu erstellende DV-Z
Dim AppExcel As Object
Dim tsVermögensverzeichnis As String 'Vermögensverzeichnis
Dim tsUnterabteilung As String 'Unterabteilung
Dim tsVermögensstock As String 'Vermögensstock
Dim tRow As Long
Dim tRowSummary As Long
Dim tRowReport As Long
Dim tRowEinzelsätze As Long
Dim tLastRow As Long
Dim tRowLog2 As Long
Dim i As Integer 'Hilfsvariablen
Dim tiCounterDirectory As Integer, tiCounterReport As Integer, tiCounterWorksheet As Integer
Dim tiEmptyRow As Integer
Dim z2 As Integer 'Hilfsvariable
Dim ESB As Double 'Betrag für Einzelsätze
Dim ESNr As String 'Kennummer für Einzelsatzliste
Dim suchstr1, suchstr2 As String 'Suchfelder
Dim VerarbeitungEinzelbuchungskreis As Boolean 'Einzelbuchungskreis
Dim tsKeyVV As String ' Schlüssel Vermögensverzeichnis (Buchungskreis, Vermögensverzeichnis, Unterabteilung)
Dim tsAmountGroup As String
Dim tvCellValue As Variant
Dim tCellValue As Double 'temp für Zellwerte im Datentyp Doubble
Dim tZwSumme As Double
Dim tdZugang As Double 'Wert Zugänge
Dim tdAbgang As Double 'Wert Abgänge
Dim tSumme As Double 'Errechnete Summe
Dim tSummeZugang As Double 'Summe Zugänge
Dim tSummeAbgang As Double 'Summe Abgänge
Dim tSummeBestand As Double 'Summe Bestand
Dim tSummeBestandEuro As Double
Dim tSummeZuganguab As Double, tSummeZuganguabEuro As Double
Dim tDiff As Double 'Differenzwert
Dim dvzz As Integer 'Zeile im "DV-Z"
Dim IsInArray As Boolean 'Zeile im Array schon vorhanden
Dim IsPartnerGelöscht As Boolean 'Kennzeichen für gelöschte Partner
Dim IsBestandNegativ As Boolean 'Kennzeichen, ob negative Bestände (Nennwerte) vorhanden sind
Dim IsBuchwertNegativ As Boolean 'Kennzeichen, ob negative Buchwerte vorhanden sind
Dim IsBestandOhneBuchwert As Boolean 'Kennzeichen, ob negative Buchwerte vorhanden sind
Dim tDatum As String 'Datumsfeld
Dim tsMsg As String
Dim flagProcess As Boolean
Dim flagBREAK As Boolean
Dim flagVortrag As Boolean
'Initialisierung
Set tWorksheetProcess = ActiveWorkbook.Worksheets("Prüfung")
Set tWorksheetSummary = ActiveWorkbook.Worksheets("Zusammenfassung")
Set tWorksheetEinzelsätze = ActiveWorkbook.Worksheets("Einzelsätze")
Set tWorksheetLOG = ActiveWorkbook.Worksheets("Log")
Set tWorksheetLOG2 = ActiveWorkbook.Worksheets("Log2")
writeLog "Initalisierung"
tsVerzeichnisName = ""
VerarbeitungEinzelbuchungskreis = False
dvzz = 1 'Startzeile im DV-Z Array
'welches Arbeitsblatt??
tWorksheetProcess.Range("C10:K500").ClearContents
tWorksheetSummary.Range("A2:K500").ClearContents
Range(tWorksheetEinzelsätze.Cells(3, 1), tWorksheetEinzelsätze.Cells(50000, 7)).ClearContents
'initalisierung des LOG-Sheets
Range(tWorksheetLOG.Cells(1, 1), tWorksheetLOG.Cells(500000, 5)).ClearContents
tWorksheetLOG.Cells(1, 2) = 2
Range(tWorksheetLOG2.Cells(1, 3), tWorksheetLOG2.Cells(500000, 4)).ClearContents
tRowLog2 = 2
tWorksheetProcess.Cells(2, 6) = "Differenzenprüfung gestartet ..."
With tWorksheetProcess
'Anfang Verarbeitung
.Cells(4, 12) = Time
' Übernahme der Vorgabewerte
tsBuchungskreis = .Cells(3, 4)
tsRootDir = .Cells(4, 4)
tDatum = .Cells(5, 4)
'Aufbau der "Statusanzeige" für die Verarbeitung
.Cells(7, 4) = "Bestand"
.Cells(7, 5) = "Zu-/Abgang"
.Cells(7, 6) = "Differenz"
.Cells(7, 7) = "VV"
.Cells(7, 8) = "Uabt"
' .Cells(7, 9) = "Vermögensart"
.Cells(7, 10) = "Bestand/Bewegung"
.Cells(7, 111) = "Blatt"
'Verarbeitung eines vorgegebenen Buchungskreis
If tsBuchungskreis = "" Then
MsgBox "Es wurde kein Buchungskreis ausgewählt!"
Exit Sub
Else
If tsBuchungskreis = "A" Then
VerarbeitungEinzelbuchungskreis = False
Else
VerarbeitungEinzelbuchungskreis = True
End If
End If
End With
'Verarbeitung aller Buchungskreise
' Startzeile für die Ausgabe in den Arbeitsblättern
tRow = cRowOffsetProcess
tRowSummary = cRowOffsetSummary
tRowEinzelsätze = cRowOffsetEinzelsätze
' Einlesen der Verzeichnisse der tWorksheetReport Verzeichnisse
tiCounterDirectory = 0
tsVerzeichnisName = Dir(tsRootDir, vbDirectory)
'**********
'Übertragen der Verzeichnisnamen für die Buchungskreise in ein Array
' bis alle Verzeichnisse übernommen oder
' bei Verarbeitung eines einzelnen Buchungskreises das Verzeichnis im Zugriff
Do Until tsVerzeichnisName = "" Or Left$(tsVerzeichnisName, 4) = tsBuchungskreis
tsVerzeichnisName = Dir
If tsVerzeichnisName <> "." And tsVerzeichnisName <> ".." Then
'Bitweiser Vergleich
If (GetAttr(tsRootDir & tsVerzeichnisName) And vbDirectory) = vbDirectory Then
tiCounterDirectory = tiCounterDirectory + 1
ReDim Preserve tVerzeichniseBuchungskreis(tiCounterDirectory)
tVerzeichniseBuchungskreis(tiCounterDirectory) = tsVerzeichnisName
End If
End If
Loop
'16.02.09:jgr:ergänzt
For i = 1 To tiCounterDirectory
ActiveWorkbook.Worksheets("Log3").Cells(i + 1, 3) = tVerzeichniseBuchungskreis(i)
Next i
writeLog "Anzahl BK (Counter): ", CDbl(tiCounterDirectory)
writeLog "Anzahl BK (UBound): ", UBound(tVerzeichniseBuchungskreis)
'**********
' = (1) ========================================
' Verarbeitung über die Anzahl der Buchungskreisverzeichnisse
' loop directory (Buchungskreise)
For tiCounterDirectory = 1 To UBound(tVerzeichniseBuchungskreis)
'Initialisierung
tSummeBestand = 0
'Vorgabewert Buchungskreis prüfen
If VerarbeitungEinzelbuchungskreis Then
tsBuchungskreis = Left(tsVerzeichnisName, 4)
Else
'der Buchungskreis steht als 4stelliger Code am Anfang des Verzeichnisnamen
tsBuchungskreis = Left(tVerzeichniseBuchungskreis(tiCounterDirectory), 4)
tsVerzeichnisName = tVerzeichniseBuchungskreis(tiCounterDirectory)
End If
'Prüfen, ob Buchungskreis überhaupt DV-Verzeichnisse hat
tsWorkDir = tsRootDir & tsVerzeichnisName & "\"
tiCounterReport = 0
tsReportName = Dir(tsWorkDir, vbDirectory)
' = (2/1) ========================================
' liest alle Report-/Dateinamen für den Buchungkskreis (innerhalb des Verzeichnisses) in ein Array
' loop files (Excel-Report Dateien)
Do While tsReportName <> ""
tsReportName = Dir
If Left(tsReportName, 9) = "REPORT_VV" And Right(tsReportName, 12) = tDatum & cSuffix Then
tiCounterReport = tiCounterReport + 1
ReDim Preserve tExcelReports(tiCounterReport)
tExcelReports(tiCounterReport) = tsReportName
End If
'16.02.09:jgr:ergänzt
For i = 1 To tiCounterReport
ActiveWorkbook.Worksheets("Log3").Cells(i + 1, 4) = tExcelReports(i)
Next i
Loop ' = (2/1) =
'wenn Vermögensverzeichnisse vorliegen
If tiCounterReport > 0 Then
writeLog "Verarbeitung Vermögensverzeichnis -- Anzahl (CounterReport):", CDbl(tiCounterReport)
' = (2/2) ========================================
' Verarbeitung der jeweiligen Reportdatei
' 16.02.09:jgr: hier stand tiCounterReport = 10
' es gibt gerade keine Erklärung, warum die ersten 9 Einträge ausgelasen wurden
For tiCounterReport = 1 To UBound(tExcelReports)
'## gesteuerter Abbruch über Eingabe
'-----------------------------------
DoEvents
If Worksheets("Prüfung").lstProcess = "STOP" Then
tWorksheetProcess.Activate
tWorksheetProcess.Range("F2") = "!!! PRÜFUNG ABBGEBROCHEN !!!"
DoEvents
MsgBox "STOP-Befehl in Auswahl!" & vbCrLf & "Verarbeitung abgebrochen!", vbInformation + vbOKOnly, "VV-Prüfung"
Exit Sub
End If
'# Kennzeichnung von
' - Vermögensverzeichnis, Unterabteilung, Vermögensstock und Berichtsart
' aus dem Dateinamen der Excel-Datei raustrennen
tsVermögensverzeichnis = Mid(tExcelReports(tiCounterReport), 10, 2)
If Mid(tExcelReports(tiCounterReport), 1, 11) = "REPORT_VV09" Then
tsUnterabteilung = Mid(tExcelReports(tiCounterReport), 15, 2)
Else
tsUnterabteilung = Mid(tExcelReports(tiCounterReport), 14, 2)
End If
' ## Vermögensstock ermitteln
' If Mid(tExcelReports(tiCounterReport), 17, 2) = "DS" Then
' tsVermögensstock = "1"
' Else
' tsVermögensstock = "2"
' End If
' ## Berichtsart ermitteln
' Select Case tsVermögensstock
' Case "1"
If Mid(tExcelReports(tiCounterReport), 1, 11) = "REPORT_VV09" Then
If Mid(tExcelReports(tiCounterReport), 18, 13) = "BESTANDSLISTE" Then
tsReportType = "Bestand"
Else
tsReportType = "Zu-/Abgang"
End If
Else
If Mid(tExcelReports(tiCounterReport), 17, 13) = "BESTANDSLISTE" Then
tsReportType = "Bestand"
Else
tsReportType = "Zu-/Abgang"
End If
End If
' Case "2"
' If Mid(tExcelReports(tiCounterReport), 30, 13) = "BESTANDSLISTE" Then
' tsReportType = "Bestand"
' Else
' tsReportType = "Zu-/Abgang"
' End If
' End Select
With tWorksheetProcess
' Kennzeichen des geprüften Berichts anzeigen
.Cells(4, 6) = tsBuchungskreis
.Cells(8, 7) = tsVermögensverzeichnis
.Cells(8, 8) = tsUnterabteilung
' .Cells(8, 9) = tsVermögensstock
.Cells(8, 10) = tsReportType
End With
tsReportName = tExcelReports(tiCounterReport)
tsFullPath = tsWorkDir & tsReportName
tsKeyVV = "'" & tsBuchungskreis & "-" & tsVermögensverzeichnis & "-" & tsUnterabteilung
'Verwendung einer eigenen Instanz um das 'Flackern' der Fenster zu unterbinden
Set AppExcel = CreateObject("Excel.Application")
'** Excel-Berichtsdatei öffnen
AppExcel.Workbooks.Open tsFullPath, 0, True
writeLog "OPEN: " & tsFullPath
writeLog "Counter Sheets: ", AppExcel.Workbooks(tsReportName).Worksheets.Count, tsKeyVV
' = (3) ========================================
' über alle Arbeitsblätter der Report-Datei
For tiCounterWorksheet = 1 To AppExcel.Workbooks(tsReportName).Worksheets.Count
IsPartnerGelöscht = False
IsBestandNegativ = False
IsBuchwertNegativ = False
IsBestandOhneBuchwert = False
tiEmptyRow = 0 '28.09.08:jgr: Initalisierung ergänzt
Set tWorksheetReport = AppExcel.Workbooks(tsReportName).Worksheets(tiCounterWorksheet)
writeLog "Sheet: " & tWorksheetReport.Name & " (Nr: " & tiCounterWorksheet & ")"
' ********** getLastRow() **********
tLastRow = cRowOffsetReport
' = (4/1) ==
'Zeilennummer der letzten Datenreihe in einer Folge ermitteln
flagProcess = True
Do While flagProcess
'Abbruchbedingung für weitere Verarbeitung
If tWorksheetReport.Cells(tLastRow, 1) <> "" Then
If Left(CStr(tWorksheetReport.Cells(tLastRow, 1)), 22) = "Gesamt-Anrechnungswert" _
Or Left(CStr(tWorksheetReport.Cells(tLastRow, 1)), 46) = "Übertrag aus dem Vorjahr: (Anrechnungswert) 1)" _
Or Left(CStr(tWorksheetReport.Cells(tLastRow, 1)), 46) = "Übertrag aus dem Vorjahr (Anrechnungswert): 1)" Then
flagProcess = False
End If
End If
'Abbruch wenn keine RegNr vorhanden
If Trim(tWorksheetReport.Range("RegNr")) = "" Then
writeLog "BREAK PROCESSING!! Keine RegNr vorhanden und damit keine Werte", , tsKeyVV
flagProcess = False
tLastRow = 1
flagBREAK = True
End If
'* Abbruch bei mehr als 15 Leerzeilen in Folge
'*----------
If tiEmptyRow > 15 Then
writeLog "BREAK PROCESSING!! Mehr als 15 Leerzeilen in Folge", , tsKeyVV
tLastRow = 1
flagProcess = False
flagBREAK = True
End If
If tWorksheetReport.Cells(tLastRow, 1) = "" Then
tiEmptyRow = tiEmptyRow + 1
Else
tiEmptyRow = 1
End If
'* Abbruch bei evtl. Fehlern
'*----------
DoEvents
If tLastRow >= 100000 Then
Debug.Print "BREAK PROCESSING!!"
writeLog "BREAK PROCESSING!! Zähler größer 100.000", , tsKeyVV
tLastRow = 1
flagProcess = False
flagBREAK = True
End If
'*----------
tLastRow = tLastRow + 1
Loop ' = (4/1) == ermitteln der letzten Zeile
'Rückgabe der Zeilennummer
tLastRow = tLastRow - 1
' ********** END getLastRow() **********
If Not flagBREAK Then
writeLog tsReportType
flagVortrag = False
Select Case tsReportType
'********************
Case "Bestand"
tWorksheetProcess.Cells(4, 9) = tWorksheetReport.Cells(22, 7) 'Listendatum
tRowReport = cRowOffsetReport
' = (4/2) ==
' Zeilenweise Auswertung des Arbeitsblattes
For tRowReport = cRowOffsetReport To tLastRow - 1
If InStr(1, tWorksheetReport.Cells(tRowReport, 3), "lösch") <> 0 Then
IsPartnerGelöscht = True
End If
If InStr(1, tWorksheetReport.Cells(tRowReport, 3), "deaktiviert") <> 0 Then
IsPartnerGelöscht = True
End If
If tWorksheetReport.Cells(tRowReport, 9) <> 0 And tWorksheetReport.Cells(tRowReport, 9) < 0 Then
IsBestandNegativ = True ' Nennwert
End If
If tWorksheetReport.Cells(tRowReport, 6) <> 0 And tWorksheetReport.Cells(tRowReport, 6) < 0 Then
IsBuchwertNegativ = True ' Buchwert
End If
If Left(tWorksheetReport.Cells(tRowReport, 1), 7) <> "Bestand" Then
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 6))
writeLog "Zelle (Spalte/Zeile) 6/" & tRowReport & " (Bestand): ", tCellValue, tsKeyVV
If tCellValue <> 0 Then
tZwSumme = tSumme + tCellValue
tSumme = tZwSumme
End If
If Not IsNumeric(tSumme) Then
MsgBox "Summe nicht numerisch"
End If
'Ausgabe der Summe in Übersicht
tWorksheetProcess.Cells(8, 4) = tSumme
writeLog " Summe (Bestand): ", tSumme
If CDbl(tWorksheetReport.Cells(tRowReport, 6)) <> 0 Then
ESB = CDbl(tWorksheetReport.Cells(tRowReport, 6))
z2 = tRowReport
Do Until tWorksheetReport.Cells(z2, 3) = ""
z2 = z2 + 1
Loop
ESNr = tWorksheetReport.Cells(z2 - 1, 3)
With tWorksheetEinzelsätze
.Cells(tRowEinzelsätze, 1) = ESNr
.Cells(tRowEinzelsätze, 2) = ESB
.Cells(tRowEinzelsätze, 3) = tsVermögensstock
.Cells(tRowEinzelsätze, 4) = tWorksheetReport.Name
.Cells(tRowEinzelsätze, 5) = tsVermögensverzeichnis
.Cells(tRowEinzelsätze, 6) = tsUnterabteilung
.Cells(tRowEinzelsätze, 7) = tsBuchungskreis
End With
tRowEinzelsätze = tRowEinzelsätze + 1
'11.03.2009:jgr:ergänzt
Else
If CDbl(tWorksheetReport.Cells(tRowReport, 9)) <> 0 Then
writeLog "Nennwert (Bestand) ohne Buchwert (Bestand)"
IsBestandOhneBuchwert = True
'Stop
End If
End If
Else
tRowReport = tRowReport + 1 'nur 1 da einer über next
End If
Next tRowReport
'Differenzberechnung
'die Summenzahl kann in unterschiedlichen Spalten liegen ...
tSummeBestand = 0
writeLog "Zelle (Spalte/Zeile) 6/" & tRowReport & " (Differenzberechnung): >" & tWorksheetReport.Cells(tRowReport, 1) & "<"
For i = 3 To 6
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, i))
writeLog "Zelle (Spalte/Zeile) " & i & "/" & tRowReport & ": ", tCellValue, tsKeyVV
If tCellValue <> 0 Then
tZwSumme = tSummeBestand + tCellValue
tSummeBestand = tZwSumme
End If
Next i
writeLog "Differenzber. SummeBestand: ", tSummeBestand
'Prüfung, ob zusätzlich in Fremdwährung
If Left(CStr(tWorksheetReport.Cells(tRowReport, 1)), 22) = "Gesamt-Anrechnungswert" _
And InStr(CStr(tWorksheetReport.Cells(tRowReport, 1)), "EUR") = 0 Then
tSummeBestandEuro = CDbl(tWorksheetReport.Cells(tRowReport + 2, 3)) _
+ CDbl(tWorksheetReport.Cells(tRowReport + 2, 4)) _
+ CDbl(tWorksheetReport.Cells(tRowReport + 2, 5)) _
+ CDbl(tWorksheetReport.Cells(tRowReport + 2, 6))
Else
tSummeBestandEuro = tSummeBestand
End If
tZwSumme = tSumme - tSummeBestand
tDiff = tZwSumme
IsInArray = False
If tSummeBestand <> 0 Then
For i = 1 To 500
If dvz(i, 1) = tsBuchungskreis And dvz(i, 2) = tsVermögensverzeichnis _
And dvz(i, 3) = tsUnterabteilung And dvz(i, 4) = tsVermögensstock _
And dvz(i, 5) = tWorksheetReport.Name Then
dvz(i, 6) = tSummeBestand
dvz(i, 9) = tSummeBestandEuro
IsInArray = True
Exit For
End If
Next i
If IsInArray = False Then
dvz(dvzz, 1) = tsBuchungskreis
dvz(dvzz, 2) = tsVermögensverzeichnis
dvz(dvzz, 3) = tsUnterabteilung
dvz(dvzz, 4) = tsVermögensstock
dvz(dvzz, 5) = tWorksheetReport.Name
dvz(dvzz, 6) = tSummeBestand
dvz(dvzz, 9) = tSummeBestandEuro
dvzz = dvzz + 1
End If
End If
'********************
Case "Zu-/Abgang"
tWorksheetProcess.Cells(4, 9) = tWorksheetReport.Cells(22, 7) 'Listendatum
tRowReport = cRowOffsetReport
For tRowReport = cRowOffsetReport To tLastRow - 1 ' letzte Zeile ("Gesamt") wird nach Schleife verarbeitet
If InStr(1, tWorksheetReport.Cells(tRowReport, 2), "summenmäßige") <> 0 Then
tCellValue = CDbl(Trim(Right(tWorksheetReport.Cells(tRowReport, 2), 15)))
If tCellValue <> 0 Then
tZwSumme = tSumme - tCellValue
tSumme = tZwSumme
End If
Else
If InStr(1, tWorksheetReport.Cells(tRowReport, 3), "lösch") <> 0 Then
IsPartnerGelöscht = True
End If
If InStr(1, tWorksheetReport.Cells(tRowReport, 3), "deaktiviert") <> 0 Then
IsPartnerGelöscht = True
End If
If tWorksheetReport.Cells(tRowReport, 9) < -0.01 Then
IsBestandNegativ = True ' Nennwert
End If
If tWorksheetReport.Cells(tRowReport, 6) < -0.01 Then
IsBuchwertNegativ = True ' Buchwert
End If
' wenn kein Vortrag
'If InStr(1, tWorksheetReport.Cells(tRowReport, 1), "Vortrag") = 0 Then
tvCellValue = tWorksheetReport.Cells(tRowReport, 1)
If tvCellValue = "" Then
tsAmountGroup = ""
Else
If InStr(1, tvCellValue, "Übertrag") > 0 Then
tsAmountGroup = "Übertrag"
ElseIf InStr(1, tvCellValue, "Bestand Vortrag") > 0 Then
tsAmountGroup = "Vortrag"
flagVortrag = True
ElseIf Left(tvCellValue, 8) = "Zugänge:" Then
'tsAmountGroup = "Zugänge"
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
tdZugang = tCellValue
ElseIf Left(tvCellValue, 8) = "Abgänge:" Then
'tsAmountGroup = "Abgänge"
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
'If tCellValue <> 0 Then Stop
tdAbgang = tCellValue
ElseIf Left(tvCellValue, 25) = "Saldo Zu-/Abschreibungen:" Then
tsAmountGroup = "Saldo Zu-/Abschreibungen"
ElseIf Left(tvCellValue, 40) = "Saldo Zu-/Abschreibungen gem. §341c HGB:" Then
tsAmountGroup = "Saldo Zu-/Abschreibungen"
ElseIf InStr(1, tvCellValue, "Gesamt") > 0 Then
tsAmountGroup = "Gesamt"
Else
' wenn der Eintrag für die Zuordnung 'Vortrag' noch nicht vorgekommen ist, handelt es sich bei den Einträgen um Zu- und Abgänge
If flagVortrag = False Then
tsAmountGroup = "Zugang/Abgang"
Else
tsAmountGroup = "-"
End If
End If
End If
Select Case tsAmountGroup
Case "Übertrag", "Zugang/Abgang"
' Zugang (Spalte 4)
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
writeLog "Zelle (Spalte/Zeile) 4/" & tRowReport & " (Zugang):", tCellValue, tsKeyVV
tSumme = tSumme + tCellValue
' Abgang (Spalte 5)
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 5))
writeLog "Zelle (Spalte/Zeile) 5/" & tRowReport & " (Abgang):", tCellValue, tsKeyVV
tSumme = tSumme - tCellValue
tZwSumme = tSummeAbgang + tCellValue
tSummeAbgang = tZwSumme
'
If InStr(1, tWorksheetReport.Cells(tRowReport, 1), "Vorjahr") = 0 Then
' wenn NICHT Vorjahr
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
tZwSumme = tSummeZugang + tCellValue
tSummeZugang = tZwSumme
End If
'Ausgabe der Summe in Übersicht
tWorksheetProcess.Cells(8, 5) = tSumme
writeLog "Summe (" & tsAmountGroup & "):", tSumme
writeLog "Summe (Zugang):", tSummeZugang
writeLog "Summe (Abgang):", tSummeAbgang
Case "Saldo Zu-/Abschreibungen"
writeLog tsAmountGroup & ":"
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
writeLog "Zelle (Spalte/Zeile) 4," & tRowReport & " :", tCellValue
If tCellValue <> 0 Then
tZwSumme = tSumme + tCellValue
tSumme = tZwSumme
End If
End Select
End If
Next tRowReport
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
writeLog "Zelle (Spalte/Zeile) 4/" & tRowReport & " (Gesamt):", tCellValue, tsKeyVV
'Differenzberechnung
tSummeZuganguab = CDbl(tWorksheetReport.Cells(tRowReport, 4))
'Prüfung, ob zusätzlich in Fremdwährung
If Left(CStr(tWorksheetReport.Cells(tRowReport, 1)), 22) = "Gesamt-Anrechnungswert" And InStr(CStr(tWorksheetReport.Cells(tRowReport, 1)), "EUR") = 0 Then
tSummeZuganguabEuro = CDbl(tWorksheetReport.Cells(tRowReport + 2, 3)) + CDbl(tWorksheetReport.Cells(tRowReport + 2, 4)) + CDbl(tWorksheetReport.Cells(tRowReport + 2, 5)) + CDbl(tWorksheetReport.Cells(tRowReport + 2, 6))
Else
tSummeZuganguabEuro = tSummeZuganguab
End If
'Differenz aus Summe - Buchwert(Zugang)
tCellValue = CDbl(tWorksheetReport.Cells(tRowReport, 4))
tZwSumme = tSumme - tCellValue
tDiff = tZwSumme
IsInArray = False
'# Protokollierung von Unregelmässigkeiten
If Round(tSummeZugang, 2) - Round(tdZugang, 2) <> 0 Then
With tWorksheetProcess
.Cells(tRow, 3) = "Differenz im Buchungskreis " & tsBuchungskreis & " bei den Zugängen in Höhe von "
.Cells(tRow, 6) = tSummeZugang - tdZugang
.Cells(tRow, 7) = tsVermögensverzeichnis
.Cells(tRow, 8) = tsUnterabteilung
.Cells(tRow, 9) = tsVermögensstock
.Cells(tRow, 10) = tsReportType
.Cells(tRow, 11) = tWorksheetReport.Name
writeLog .Cells(tRow, 3), .Cells(tRow, 6)
End With
tRow = tRow + 1
End If
If Round(tSummeAbgang, 2) + Round(tdAbgang, 2) <> 0 Then
With tWorksheetProcess
.Cells(tRow, 3) = "Differenz im Buchungskreis " & tsBuchungskreis & " bei den Abgängen in Höhe von "
.Cells(tRow, 6) = tSummeAbgang + tdAbgang
.Cells(tRow, 7) = tsVermögensverzeichnis
.Cells(tRow, 8) = tsUnterabteilung
.Cells(tRow, 9) = tsVermögensstock
.Cells(tRow, 10) = tsReportType
.Cells(tRow, 11) = tWorksheetReport.Name
writeLog .Cells(tRow, 3), .Cells(tRow, 6)
End With
tRow = tRow + 1
End If
If tSummeZuganguab <> 0 Then
For i = 1 To 500
If dvz(i, 1) = tsBuchungskreis And dvz(i, 2) = tsVermögensverzeichnis And dvz(i, 3) = tsUnterabteilung And dvz(i, 4) = tsVermögensstock And dvz(i, 5) = tWorksheetReport.Name Then
dvz(i, 7) = tSummeZuganguab
dvz(i, 10) = tSummeZuganguabEuro
IsInArray = True
Exit For
End If
Next i
If Not IsInArray Then
dvz(dvzz, 1) = tsBuchungskreis
dvz(dvzz, 2) = tsVermögensverzeichnis
dvz(dvzz, 3) = tsUnterabteilung
dvz(dvzz, 4) = tsVermögensstock
dvz(dvzz, 5) = tWorksheetReport.Name
dvz(dvzz, 7) = tSummeZuganguab
dvz(dvzz, 10) = tSummeZuganguabEuro
dvzz = dvzz + 1
End If
End If
End Select
'** ------
End If
' If tsReportName = "REPORT_VV11_U01_DS_ZU_UND_ABGANG_20080930.xls" Then
' Debug.Print "x"
' End If
With tWorksheetProcess
'Ergebnis schreiben, wenn Differenz mehr als Rundung
If tDiff > 1 Or tDiff < -1 Then
.Cells(tRow, 3) = "Differenz im Buchungskreis " & tsBuchungskreis & " in Höhe von "
.Cells(tRow, 6) = tDiff
.Cells(tRow, 7) = tsVermögensverzeichnis
.Cells(tRow, 8) = tsUnterabteilung
.Cells(tRow, 9) = tsVermögensstock
.Cells(tRow, 10) = tsReportType
.Cells(tRow, 11) = tWorksheetReport.Name
tRow = tRow + 1
End If
tSumme = 0
tSummeZugang = 0
tSummeAbgang = 0
tsMsg = "Im Buchungskreis " & tsBuchungskreis & " im Vermögensverzeichnis " & tsVermögensverzeichnis & ", Uabt " & tsUnterabteilung & ", Sparte " & tWorksheetReport.Name
If IsPartnerGelöscht = True Then
.Cells(tRow, 3) = tsMsg & " befinden sich höchstwahrscheinlich gelöschte Partner! (" & tsReportType & ")"
tRow = tRow + 1
IsPartnerGelöscht = False
End If
If IsBestandNegativ = True Then
.Cells(tRow, 3) = tsMsg & " befinden sich negative Nominalbestände! (" & tsReportType & ")"
tRow = tRow + 1
IsBestandNegativ = False
End If
If IsBuchwertNegativ = True Then
.Cells(tRow, 3) = tsMsg & " befinden sich negative Buchwerte! (" & tsReportType & ")"
tRow = tRow + 1
IsBuchwertNegativ = False
End If
If IsBestandOhneBuchwert = True Then
.Cells(tRow, 3) = tsMsg & " befinden sich Nennwerte ohne Buchwerte! (" & tsReportType & ")"
tRow = tRow + 1
IsBuchwertNegativ = False
End If
End With
'28.09.08:jgr:ergänzt
If flagBREAK = True Then
tWorksheetLOG2.Cells(tRowLog2, 3) = "Verarbeitung ABGEBROCHEN ! BuKr:" & tsBuchungskreis & ", VV:" & tsVermögensverzeichnis & ", Uabt:" & tsUnterabteilung & ", VS:" & tsVermögensstock & ", Type:" & tsReportType
tWorksheetLOG2.Cells(tRowLog2, 4) = tsReportName
tRowLog2 = tRowLog2 + 1
flagBREAK = False
End If
Next tiCounterWorksheet
AppExcel.Workbooks(tsReportName).Close SaveChanges:=False
Next tiCounterReport
Else
tsMsg = "Der Buchungskreis " & tsBuchungskreis & " hat keine Vermögensverzeichnisse (oder nicht zum eingegebenen Datum)!"
tWorksheetProcess.Cells(tRow, 3) = tsMsg
tRow = tRow + 1
End If
If VerarbeitungEinzelbuchungskreis Then
Exit For
End If
Next tiCounterDirectory
'Ausgabe der Werte als "Zusammenfassung"
With tWorksheetSummary
For i = 1 To 500
If dvz(i, 1) <> "" Then
'wegen der Kopfzeile (Spaltenüberschrift, Werte immer eine Zeile 'tiefer' (+1) schreiben
.Cells(i + 1, 1) = dvz(i, 1)
.Cells(i + 1, 2) = dvz(i, 2)
.Cells(i + 1, 3) = dvz(i, 3)
.Cells(i + 1, 4) = dvz(i, 4)
.Cells(i + 1, 5) = dvz(i, 5)
.Cells(i + 1, 6) = dvz(i, 6) ' Bestand Whg
.Cells(i + 1, 7) = dvz(i, 7) ' Zu-/Abgang Whg
.Cells(i + 1, 8) = dvz(i, 6) - dvz(i, 7) ' Differenz Whg
.Cells(i + 1, 9) = dvz(i, 9) ' Bestand €
.Cells(i + 1, 10) = dvz(i, 10) ' Zu-/Abgang €
.Cells(i + 1, 11) = dvz(i, 9) - dvz(i, 10) ' Differenz €
End If
Next i
End With
tWorksheetProcess.Cells(2, 6) = "Differenzenprüfung abgeschlossen!"
writeLog "Differenzenprüfung abgeschlossen!"
'Ende Verarbeitung
tWorksheetProcess.Cells(4, 13) = Time
End Sub
'******************************
Public Function writeLog(pMsg As String, Optional pSumme As Double, Optional pZuordnung)
'******************************
Dim tRow As Long
tRow = CLng(ActiveWorkbook.Worksheets("LOG").Cells(1, 2)) + 1
ActiveWorkbook.Worksheets("LOG").Cells(tRow, 2) = Time
ActiveWorkbook.Worksheets("LOG").Cells(tRow, 3) = pMsg
If pSumme > 0 Then
ActiveWorkbook.Worksheets("LOG").Cells(tRow, 4) = pSumme
End If
ActiveWorkbook.Worksheets("LOG").Cells(tRow, 5) = pZuordnung
ActiveWorkbook.Worksheets("LOG").Cells(1, 2) = tRow
End Function
'******************************
Private Sub cmdProcess_Click()
'******************************
Dim tMsg As String, tAnswer As Integer
If Range("D3") = "A" Then
tMsg = "Prüfung wird über alle Solvency-I-Buchungskreise durchgeführt!"
tAnswer = MsgBox(tMsg, vbExclamation + vbOKCancel, "VV-Prüffung")
If tAnswer = vbOK Then
flagProcess = True
Else
flagProcess = False
End If
Else
flagProcess = True
End If
If flagProcess Then
Call doProcess1
End If
End Sub
|