Abgleich zw. Ordner und Tabelle

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Abrechnungsquote() Dim wotag As String Dim datumtag As String Dim quoteB2B As Double Workbooks.Open Filename:="U:\OpEx\Projekt\TP 3 Prozesse\AP 3.4 Prozessanalyse\0.3 _ Wertpapiertransaktionsprozess\KPI - DWH\Testordner\KPI WP-TRX Fonds_070827.xls" Sheets("Pivottabelle 7").Select Range("D4").Select wotag = Selection.Value Range("F4").Select datumtag = Selection.Value Range("D7").Select quoteB2B = Selection.Value Workbooks("KPI WP-TRX Fonds_070827.xls").Close Windows("KPI Gesamtbericht WP Trans B2B_Live_Makro_v0.1.xls").Activate Sheets("Abrechnungsquote Fonds").Select lr = Cells(Rows.Count, 3).End(xlUp).Row + 1 Range("B" & lr).Select ActiveCell.Formula = wotag Range("C" & lr).Select ActiveCell.Formula = datumtag Range("F" & lr).Select ActiveCell.Formula = (quoteB2B * 100) End Sub

Hallo Thomas,
ich habe angenommen, das der Code in einem Modul der Mappe in die die Daten geschrieben werden steht. Es werden alle Dateien im angegebenen Verzeichnis ausgelesen.
Das Sheet "Logfile" mus existieren. Die Logdaten werden ab Zeile 3 eingetragen. Dateien die bereits im Logfile stehen, werden nicht erneut ausgelesen.
Der Code ist ungetestet, weil ich weder deinen Verzeichnispfad, noch die Dateien nachbauen will!
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

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 = "U:\OpEx\Projekt\TP 3 Prozesse\AP 3.4 Prozessanalyse\0.3 Wertpapiertransaktionsprozess\KPI - DWH\Testordner\"

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("B:B").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 Fonds")
                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)
            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ß Sepp

Hallo Thomas,
das kommt, weil du das Datum als Text in die Tabelle schreibst. Und Text wird nunmal anders sortiert als Zahlen.
Ich habe das jezt umgestellt. Es wird nun das Datum als "echtes" Datum eingetragen.
Die Sortierung sollte jetzt klappen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Abrechnungsquote()
Dim objThWB As Workbook, objWb As Workbook
Dim wotag As String, datumtag As Date, 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 = "U:\OpEx\Projekt\TP 3 Prozesse\AP 3.4 Prozessanalyse\0.3 Wertpapiertransaktionsprozess\KPI - DWH\Testordner\"

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("B:B").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 = CDate(.Range("F4").Value)
                quoteB2B = .Range("D7").Value
            End With

            objWb.Close False

            With objThWB.Sheets("Abrechnungsquote Fonds")
                lngRow = .Cells(Rows.Count, 3).End(xlUp).Row + 1
                .Cells(lngRow, 2) = wotag
                .Cells(lngRow, 3) = CDate(datumtag)
                .Cells(lngRow, 6) = (quoteB2B * 100)
            End With

        End If

    Next

    If lngRow > 0 Then
        With objThWB.Sheets("Abrechnungsquote Fonds")
            .Range(.Cells(47, 1), .Cells(lngRow, 14)).Sort _
                Key1:=.Cells(47, 3), _
                Order1:=xlDescending, _
                Header:=xlNo
            'Order1:= xlAscendin, _ um aufsteigend zu sortieren.
        End With
    End If

End If

ErrExit:
GMS True

Set objWb = Nothing
Set objThWB = Nothing
Set objFSO = Nothing

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread