AW: Mittelwert
07.09.2007 14:32:00
Thomas
Hallo Jan
Also die Exceldatei ist leider zu groß (ca.500kb). Deswegen hier der Code und zusätzlich noch Screenshots der einzelnen Tabellenblätter:
Sub Abrechnungsquote()
Dim objThWB As Workbook, objWb As Workbook
Dim wotag As String, datumtag As String, quoteB2B As Double
Dim a As Variant, objFSO
Dim result As Long, lngI As Long, lngR As Long, lngRow As Long
Dim strFile As String, strPath As String
Dim rng As Range
On Error GoTo ErrExit
GMS
'Pfad der durchsucht werden soll
strPath = "XY:\OpEx\Projekt\TP 3 Prozesse\AP 3.4 Prozessanalyse\0.3 Wertpapiertransaktionsprozess\KPI - DWH\Testordner\Fonds\"
If Right(strPath, 1) "\" Then strPath = strPath & "\"
'Dateisuche
result = FileSearchFSO(a, strPath, "*.xls", False)
Set objThWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
If result 0 Then
lngR = Application.Max(objThWB.Sheets("Loginfo").Cells(Rows.Count, 1).End(xlUp).Row + 1, 3)
For lngI = 0 To UBound(a)
strFile = objFSO.GetFileName(a(lngI))
'Feststellen ob Datei bereits ausgelesen wurde
Set rng = objThWB.Sheets("Loginfo").Range("A:C").Find(strFile, LookAt:=xlWhole)
If rng Is Nothing Then
With objThWB.Sheets("Loginfo")
.Cells(lngR, 1) = Application.Max(.Range("A:A")) + 1
.Cells(lngR, 2) = strFile
.Cells(lngR, 3) = Now
lngR = lngR + 1
End With
Set objWb = Workbooks.Open(a(lngI))
With objWb.Sheets("Pivottabelle 7")
wotag = .Range("D4").Value
datumtag = .Range("F4").Value
quoteB2B = .Range("D7").Value
End With
objWb.Close False
With objThWB.Sheets("Abrechnungsquote")
lngRow = .Cells(Rows.Count, 3).End(xlUp).Row + 1
.Cells(lngRow, 2).Formula = wotag
.Cells(lngRow, 3).Formula = datumtag
.Cells(lngRow, 6).Formula = (quoteB2B * 100)
.Cells(lngRow, 4).Formula = "DWH"
.Cells(lngRow, 5).Formula = "Prozent"
If wotag = "Mo" Then
Range("G" & lngRow).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(RC[-1]:R[4]C[-1])"
End If
End With
End If
Next
End If
ErrExit:
GMS True
Set objWb = Nothing
Set objThWB = Nothing
Set objFSO = Nothing
End Sub
Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
Dim objFSO As Object, fsoFolder As Object, fsoSubFolder As Object, fsoFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set fsoFolder = objFSO.GetFolder(InitialPath)
On Error Resume Next
For Each fsoFile In fsoFolder.Files
If Not fsoFile Is Nothing Then
If LCase(objFSO.GetFileName(fsoFile)) Like LCase(FileName) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Files(UBound(Files)) = fsoFile
End If
End If
Next
If SubFolders Then
For Each fsoSubFolder In fsoFolder.SubFolders
FileSearchFSO Files, fsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set objFSO = Nothing
Set fsoFolder = Nothing
End Function
Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Modus Then
.Calculation = lngCalc
Else
lngCalc = .Calculation
End If
.Cursor = IIf(Modus, -4143, 2)
.CutCopyMode = False
End With
End Sub
Gruß
Thomas