Makro erstellen zur Auswertung/Übertrag von 2 Excelmappen

Hi, bräuchte Hilfe um ein Makro zu erzeugen mit Visual Basic in Office 2003.
Auf Laufwerk "c" liegen zwei Ordner. Ordner A und Ordner B.
In Ordner A sind Bestellscheine abgelegt, und
in Ordner B ist eine Übersichtstabelle abgelegt.

Bestellschein ist wie folgt gegliedert:

Spalte A------------------Spalte B----------------Spalte C
Art.-Nummer:-----------Bezeichnung:----------Anzahl:
02387---------------------Reifen--------------------5
09275---------------------Handschuh-------------3


Übersichtstabelle wie folgt:

Spalte A-----------------Spalte B-----------------Spalte C---------------------------------Spalte D
Art.-Nummer:----------Bezeichnung:----------Anzahl von Bestellschein 1--------Anzahl von Bestellschein 2
02387--------------------Reifen---------------------5
09275--------------------Handschuh--------------3

Nun möchte ich in der Spalte C in der Übersichtstabelle ein Makro ausführen, welches anhand von den Artikelnummern die Anzahl aus dem Bestellschein 1 einfügt.
mit programmierung hatte ich noch gar nichts am Hut und kann auch nicht abschätzen, wie groß der Aufwand hierzu ist.


Besten Dank.
gruß nohax

 

Hallo chooka

Ein Makro wäre vermutlich schon aufwändig, ich wüsste jetzt auch noch nicht wie und ob ich überhaupt helfen könnte...
Versuche es doch einmal mit SVERWEIS !

Annahmen für die Mappe mit der Uebersichtstabelle >
- in Spalten A + B sind alle vorhandenen Artikel-Nummern und -Bezeichnungen aufgeführt
- ab Spalte C erhält jeder Bestellschein eine Spalte, also max. 254 Scheine

Dann setze in Zelle C2 diese Formel >

Code:

=WENN(ISTNV(SVERWEIS($A2;'C:\Bestellscheine\[Bestellschein1.xls]Tabelle1'!$A$2:$C$20;3;FALSCH))=WAHR;"";SVERWEIS($A2;'C:\Bestellscheine\[Bestellschein1.xls]Tabelle1'!$A$2:$C$20;3;FALSCH))

Den Namen des Pfades zum Ordner mit den Bestellscheinen, den Namen der Datei Bestellschein1.xls und den Namen des Blattes mit dem Bestellschein (hier Tabelle1) natürlich an Deine Namen anpassen.
Ebenso die maximale Zeilenanzahl eines Bestellscheins, hier ist es der Bereich A2:C20 (aber die $-Zeichen nicht vergessen...).

Dann die Zelle C2 nach rechts kopieren, soweit wie nötig...
...und in jeder Spalte den Dateinamen (die Bestellnummer) ändern.

Erst jetzt alle Formelzellen in Zeile 2 hinunter kopieren, soweit wie es Artikelnummern hat.

Gruss Urs

 

Hi URS2,
besten Dank für die Formel.
Habe gestern selbst noch mit Hilfe von google folgende Formel entworfen.

HTML:

=SVERWEIS(WERT($A4);'C:\Users\name\Desktop\OrdnerA\[Bestellschein1]Tabelle1'!$A$2:$1$4108;3;0)

und es hat sogar funktioniert. Dachte immer, der sverweis geht nur innerhalb einer Mappe.
Deine Formel scheint mir aber ausgereifter und werde sie mal anwenden.
Was ich aber an meiner Formel noch nicht verstehe, ist der Bereich "$1$4108;3;0)" die 3 steht für die Spalte. Was aber bedeutet die 0?

Am schönsten wäre es ja, wenn ich den Bestellschein in Ordner A verschiebe und er automatisch in die Übersichtstabelle übernommen wird.
Das Problem:
Die NAmen der Bestellscheine sind im gesamten:
1234-rf-01-Bestellschein1-2010-10-08
1234-rf-02-Bestellschein2-2010-10-12
1234-rf-03-Bestellschein3-2010-10-18.

Ist es auch möglich, dass nur der Bereich ohne Datum ausreicht, um die Daten zu übertragen?
Denn sonst müsste ich ja für jeden Bestellschein die Formel in der Übersicht umbennen, aufgrund des Datums.



gruß chooka

 

Hallo chooka

Meine Formel ergänzt Deine Formel >
Das WENN() entfernt das hässliche #NV, das in der Zelle erscheinen würde, falls SVERWEIS keine Uebereinstimmung findet.

Die Null in Deinem SVERWEIS entspricht meinem FALSCH. In Formeln gilt für Excel "1" = WAHR, alles andere oder gar nichts gilt als FALSCH.
FALSCH bewirkt, dass eine genaue Uebereinstimmung gefunden werden muss. Wenn keine gefunden wird, kommt das #NV... oder mit meinem WENN() dann eben gar nichts,
WAHR würde einfach den nächsthöheren Wert in der Sortierung als "gefunden" auswerten.

...habe mir fast gedacht, dass Dich das Anpassen der Formeln nicht freut...
SVERWEIS kann viel, man muss ihm aber schon beibringen in welcher Datei er suchen soll...

Ich kann ja mal schauen, ob ich ich ein automatisches Makro hin kriege. Dazu folgende Fragen >

1. Um wie viele Bestellscheine geht es denn überhaupt ?
Wie viele verschiedene Artikel (also Zeilen in der Uebersicht) gibt es ?

2. im OrdnerA sind ausschliesslich Bestellscheine ?

3. 1234-rf-01-Bestellschein1-2010-10-08 ist der Name einer normalen ExcelMappe mit .xls am Ende ?
Das Blatt mit den Daten heisst immer Tabelle1 ?

4. Könntest Du den Dateinamen ändern auf 1234-rf-001-Bestellschein001-2010-10-08 ?
Damit auch mehrstellige Ordnungszahlen im Explorer richtig sortiert werden (max 254 in Excel2003)

5. Wenn die Bestellscheine einmal im OrdnerA sind, dann werden sie nie mehr verändert ?
Oder muss man jedes Mal alle Scheine wieder neu auswerten ?

Gruss Urs

 

Richtig, aber auch für mich selbst schreibe ich es immer hin.
Nach Wochen oder Monaten sind lange Formeln für mich so einfach besser lesbar.

Gruss Urs

 

Hallo Urs,

nana, was glaubst du wie ich mich gefreut habe, als plötzlich das #NV nicht mehr auftauchte.

es werden am Ende vermutlich zwischen 60-80 Bestellscheine sein.

Ja

Der Dateityp xls wird immer angezeigt und das Blatt mit den Daten heisst immer Tabelle 1.

wird vermutllich schwierig, da es sich um einen Firmenrechner handelt und somit alleEinstellungen deaktiviert sind. Werd es aber morgen gleich mal testen.

werden nicht verändert. Bestellschein wird ausgelöst und kommt dann in Ordner A.

Vielen Dank bis dahin,
gruß chooka

 

Hallo chooka

Das war auch Neuland für mich - bei mir tut es jetzt aber was ich mir vorstelle, dass es das tun soll.
Teste es einmal mit einer ganz neuen XLS, wie diese heisst und wo sie gespeichert ist, ist dem Makro egal.
Es macht natürlich nichts an Deinen Bestellscheinen - es liest sie nur aus und verarbeitet sie in der neuen Datei.

In dieser neuen Datei >>> Rechtsclick auf den Tab des Arbeitsblattes >>> Code anzeigen...
...jetzt öffnet sich der VB-Editor an der richtigen Stelle (bei Tabelle1).
Hier im weissen Feld diesen kompletten Code hinein kopieren >>>

Code:

Option Explicit

Sub ScheineAuslesen()

Dim fs As FileSearch, wb As Excel.Workbook, wbName As String, wbNum, strBest As String
Dim dirScheine As String, numScheine As Long, colScheine As Long
Dim i, j, artNum As String, artAnz, artRow, newColumn, zz

dirScheine = [COLOR="Red"]"C:\docs\$downloads\$Forum\chooka\Bestellscheine"[/COLOR]  '= Ordner mit den Bestellscheinen
strBest = [COLOR="red"]"Bestellschein"[/COLOR]   '= Text im Dateinamen vor der Zahl... zB bei Bestellschein23

                'verhindert Bildschirmflackern
Application.ScreenUpdating = False

Set fs = Application.FileSearch
                'zählt die Bestellscheine im Ordner
With fs
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    .LookIn = dirScheine
    .Execute
    numScheine = .FoundFiles.Count
                'zählt die schon eingetragenen Scheine
    colScheine = Range("IV1").End(xlToLeft).Column - 2
                'wenn Anzahl identisch > keine neuen Scheine >>> fertig
    If colScheine = numScheine Then Exit Sub
                'wenn mehr Scheine in Tabelle als im Ordner... ist etwas faul >>> prüfen !
    If colScheine > numScheine Then
        MsgBox "In der Zusammenfassung sind " & colScheine & " Scheine enthalten..." & vbCr & _
                "...der Ordner '" & dirScheine & "' enthält aber nur " & numScheine & " Dateien!      " & vbCr & vbCr & _
                "Bitte überprüfen !", vbOKOnly, "  Achtung >>>"
        Exit Sub
    End If
                        'geht der Reihe nach ganzes Verzeichnis durch
    For i = 1 To .FoundFiles.Count
                        'liest Bestellnummer aus dem Dateinamen
        wbName = Mid$(.FoundFiles(i), InStrRev(.FoundFiles(i), "\") + 1)
        wbNum = Val(Right(wbName, Len(wbName) - InStrRev(wbName, strBest) - Len(strBest) + 1))
                        'prüft ob Nummer schon in der Zusammenfassung
        With Worksheets(1).Rows(1)
            Set zz = .Find(strBest & wbNum)
        End With
                        'wenn ja > macht gar nichts
        If zz Is Nothing Then
                        'sonst öffnet Bestellschein
            Set wb = Workbooks.Open(.FoundFiles(i), True, True)
            With ThisWorkbook.Worksheets(1)
                newColumn = Range("IV1").End(xlToLeft).Column + 1
                        'trägt Bestellscheinnummer in Titelzeile ein
                .Cells(1, newColumn) = strBest & wbNum
                j = 2
                Do
                        'liest zeilenweise im Bestellschein
                    With wb.Worksheets(1)
                        artNum = .Cells(j, 1)
                        artAnz = .Cells(j, 3)
                    End With
                        'wenn keine Artikelnummer mehr > fertig mit dieser Datei
                    If artNum = "" Then Exit Do
                        'trägt Menge in entsprechender Zeile ein
                    Set zz = .Columns(1).Find(artNum)
                    artRow = zz.Row
                    .Cells(artRow, newColumn) = artAnz
                        'geht zur nächsten Zeile
                    j = j + 1
                Loop
            End With
                        'fertig mit diesem Bestellschein
            wb.Close False
        End If
    Next
End With
                        'stellt Bildschirm wieder auf Normal
Application.ScreenUpdating = True

End Sub

Bedingungen >

- die roten Angaben im Code Deinem Verzeichnis anpassen, der Dateiname scheint ja das "Bestellschein zu enthalten.
Den Rest sucht sich das Makro selbst...

- Der Code arbeitet jetzt überall mit dem ersten (oder dem einzigen) Arbeitsblatt.

- In der neuen XLS musst Du alle möglichen Bestellnummern ab Zelle A2 abwärts eintragen >
> der Code sucht diese und trägt dann die Anzahl in der gleichen Zeile ein.

- Der Code trägt die Titelzeile zB "Bestellschein15" ein > dieser Text darf nicht geändert werden, sonst findet er ihn nicht mehr.
Er schreibt nur in Spalten C und folgende, A + B musst Du eintragen.

- Sortieren ist nicht nötig, Du kannst die Dateinamen so lassen.
Beim ersten Durchgang sind die Spalten vielleicht nicht sortiert, dass kann man von Hand sortieren lassen.
Nachher wird jede neue Spalte hinten angehängt.

Jetzt nur noch das Makro starten... und hoffen, dass es auch etwas Vernünftiges tut...

Gruss Urs

 

Hallo Urs,

besten Dank für solch eine Hilfe. Hab es soeben zuhaus probiert, hat aber leider noch nicht geklappt. Noch kommt die Fehlermeldung "Objekt unterstützt diese Aktion nicht (Fehler 445)". Gibt es hierbei ein Unterschied zwischen Office 2007 und Office 2003?
Bin aber grad dran alles nachzuvollziehen, was du da geschrieben hast und hoffe, dass ich es am Ende zum laufen bekomme.
Was mich noch wundert ist, das du sagst, die Nummern der Bestellscheine müssen ab Zelle A2 abwärts eingetragen werden. Da sind aber eigentlich meine Artikelnummern aufgeführt.
Bevor ich aber jetzt zuviel Fragen stelle, werde ich mich erst mal mit dem code auseinandersetzten.
Nochmals besten dank.
gruß chooka

 

Hallo chooka

1. Eigentlich sollten zwischen 2003 und 2007 keine Unterschiede sein, es ist das gleiche VBA.

2. Fehlermeldung 445 > besonders blöde Fehlermeldung > die zeigt nie an in welcher Zeile sie den Fehler findet.
Im Code auf den linken grauen Rand clicken > dort erscheint dann ein brauner Punkt. Der Code hält jetzt bei diesem Haltepunkt an. Mit Verschieben dieses Haltepunktes kann man eingrenzen, wo das Makro einen Fehler sieht...

3. Oeffne das Makro im VB-Editor, dann Menü Extras >> Verweise...
Wo sind bei Dir dort die Haken gesetzt? Vielleicht wird eine notwendige Bibliothek nicht geladen...

4. Bestellscheinnummern... mein Schreib-Fehler hier, das Makro macht es schon richtig...
Ab Zelle A2 abwärts müssen natürlich alle Artikel-Nummern stehen, wie in Deinem ersten Beitrag beschrieben.

Gruss Urs

 

Hi Urs,

Laufzeitfehler beginnt ab der Zeile With fs. Ab da kommt immer die Fehlermeldung.

Code:

Option Explicit

Sub ScheineAuslesen()

Dim fs As FileSearch, wb As Excel.Workbook, wbName As String, wbNum, strBest As String
Dim dirScheine As String, numScheine As Long, colScheine As Long
Dim i, j, artNum As String, artAnz, artRow, newColumn, zz

dirScheine = "C:\Users\steff\Desktop\neu"  '= Ordner mit den Bestellscheinen
strBest = "Bestellschein"   '= Text im Dateinamen vor der Zahl... zB bei Bestellschein23

                'verhindert Bildschirmflackern
Application.ScreenUpdating = False

Set fs = Application.FileSearch
                'zählt die Bestellscheine im Ordner
[COLOR="Red"]With fs[/COLOR]
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    .LookIn = dirScheine
    .Execute
    numScheine = .FoundFiles.Count
                'zählt die schon eingetragenen Scheine
    colScheine = Range("IV1").End(xlToLeft).Column - 2
                'wenn Anzahl identisch > keine neuen Scheine >>> fertig
    If colScheine = numScheine Then Exit Sub
                'wenn mehr Scheine in Tabelle als im Ordner... ist etwas faul >>> prüfen !
    If colScheine > numScheine Then
        MsgBox "In der Zusammenfassung sind " & colScheine & " Scheine enthalten..." & vbCr & _
                "...der Ordner '" & dirScheine & "' enthält aber nur " & numScheine & " Dateien!      " & vbCr & vbCr & _
                "Bitte überprüfen !", vbOKOnly, "  Achtung >>>"
        Exit Sub
    End If
                        'geht der Reihe nach ganzes Verzeichnis durch
    For i = 1 To .FoundFiles.Count
                        'liest Bestellnummer aus dem Dateinamen
        wbName = Mid$(.FoundFiles(i), InStrRev(.FoundFiles(i), "\") + 1)
        wbNum = Val(Right(wbName, Len(wbName) - InStrRev(wbName, strBest) - Len(strBest) + 1))
                        'prüft ob Nummer schon in der Zusammenfassung
        With Worksheets(1).Rows(1)
            Set zz = .Find(strBest & wbNum)
        End With
                        'wenn ja > macht gar nichts
        If zz Is Nothing Then
                        'sonst öffnet Bestellschein
            Set wb = Workbooks.Open(.FoundFiles(i), True, True)
            With ThisWorkbook.Worksheets(1)
                newColumn = Range("IV1").End(xlToLeft).Column + 1
                        'trägt Bestellscheinnummer in Titelzeile ein
                .Cells(1, newColumn) = strBest & wbNum
                j = 2
                Do
                        'liest zeilenweise im Bestellschein
                    With wb.Worksheets(1)
                        artNum = .Cells(j, 1)
                        artAnz = .Cells(j, 3)
                    End With
                        'wenn keine Artikelnummer mehr > fertig mit dieser Datei
                    If artNum = "" Then Exit Do
                        'trägt Menge in entsprechender Zeile ein
                    Set zz = .Columns(1).Find(artNum)
                    artRow = zz.Row
                    .Cells(artRow, newColumn) = artAnz
                        'geht zur nächsten Zeile
                    j = j + 1
                Loop
            End With
                        'fertig mit diesem Bestellschein
            wb.Close False
        End If
    Next
End With
                        'stellt Bildschirm wieder auf Normal
Application.ScreenUpdating = True

End Sub

Haken sind gesetzt bei den ersten 4.
Visual Basic for Application,
Microsoft excel 12.0 Objekt Library,
OLE Automation,
Microsoft Office 12.0 Objekt Library,

hab es bisher leider noch nicht zum laufen gebracht. Bei der Arbeit unter Office 2003 wurde ein Syntaxfehler angezeigt bei der Zeile Msgbox.


Viele Grüße,
chooka

 

...bei mir auch, nur heissen die beiden Object Libraries bei meinem Excel2003 natürlich 11.0 (12.0 ist 2007)
Ob da ein Unterschied ist ?

Was an der MsgBox jetzt falsch sein soll, weiss ich nicht...
- entferne die beiden Apostrophs, die dort neben den Anführungszeichen sind ???
- kommentiere die Zeile mit der MsgBox einfach aus, dann sieht man ob es sonst läuft ???

Meine Datei kompiliert und läuft bei mir ohne Gemecker.
Ich hänge sie hier an - es ist eine normale XLS, nur die .TXT-Endung entfernen.

Excel2007 müsste sie allerdings dann erst konvertieren...

Im Code zuerst in der Zeile "dirScheine = " Deinen Pfad eintragen.
Und die Spalte A mit Deinen Artikel-Nummern füllen.

Gruss Urs

 

Hallo Urs,

vielen Dank.
Deine Liste bei der Arbeit getestet und alles funktionierte. Spitze.
Zuhaus unter Office 2007 geht es leider immer noch nicht. Ist aber nicht so wichtig. Werde mal in den Makroeinstellungen rumspielen, irgendwann wird es dann auch hier klappen.
Da hast du echt ein klasse Makro geschrieben. Alle Bestellscheine wurden richtig eingelesen und erleichtert mir angenehm die Arbeit.
Jetzt muss ich mich nur noch durch deine Zeilen durchkämpfen, damit ich auch verstehe, warum das Makro das tut was es soll.

Mit den besten Grüßen,
chooka


Hab das Problem, so glaube ich, gefunden. Unter Office 2007 steht das Application.FileSearch -Objekt nicht mehr zur Verfügung.

 

...und in Excel2010 dann natürlich auch nicht.

Stimmt, das wusste ich nicht.
Als Ersatz bietet sich der Dir-Befehl an, aber dann müsste man das ganze Makro neu schreiben...

Gruss Urs

 

Hallo Urs2,
vor 2 Jahren hast du mir ein Makro geschrieben, dass mir die Arbeit sehr erleichtert hat und auch ein wichtiger Bestandteil in unserem Büro geworden ist. Nun wurde bei uns auf Excel 2010 umgestiegen, was zur Folge hat, dass das Makro nicht mehr lauffähig ist. Das Problem ist die Funktion FileSearch, welche nicht mehr in 2010 (und 2007) vorkommt. Auf unsere IT Abteilung kann ich mit dem Problem nicht zugehen.
Daher möchte ich bei dir vorsichtig anfragen, ob du bei Gelegenheit das Makro anpassen kannst. Natürlich darf auch jeder Andere mir hierbei helfen, das Makro anzupassen.Ich selber bekomme das nicht hin. Die Logik hinter VBA erschließt sich mir nicht. Ich kann lediglich mini Makros schreiben, aber in dem Umfang... .
Gefunden zu dem Thema hab ich Folgendes:
Alternative zu Application.FileSearch
In einem Standardmodul:

Code:

Option Explicit

Public Enum SORT_BY
    Sort_by_None
    Sort_by_Name
    Sort_by_Path
    Sort_by_Size
    Sort_by_Last_Access
    Sort_by_Last_Modyfy
    Sort_by_Date_Create
End Enum

Public Enum SORT_ORDER
    Sort_Order_Ascending
    Sort_Order_Descending
End Enum

Public Type FILEINFO
    strFilename As String
    strPath As String
    lngSize As Long
    dmtLastAccess As Date
    dmtLastModify As Date
    dmtDateCreate As Date
End Type

Public Sub Test()
    Dim objFileSearch As clsFileSearch
    Dim lngIndex As Long
   
    Set objFileSearch = New clsFileSearch
    With objFileSearch
        .CaseSenstiv = True
        .Extension = "*.xls"
        .FolderPath = "D:\"
        .SearchLike = "Test*"
        .SubFolders = True
        If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
            For lngIndex = 1 To .FileCount
                With .Files(lngIndex)
                    Debug.Print .strFilename, .lngSize
                End With
            Next
        End If
    End With
    Set objFileSearch = Nothing
End Sub

In einem Klassenmodul mit dem Namen clsFileSearch:

Code:

Option Explicit

Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( _
    ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" ( _
    ByRef lpFileTime As FILETIME, _
    ByRef lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" ( _
    ByRef lpFileTime As FILETIME, _
    ByRef lpSystemTime As SYSTEMTIME) As Long

Private Enum FILE_ATTRIBUTE
    FILE_ATTRIBUTE_READONLY = &H1
    FILE_ATTRIBUTE_HIDDEN = &H2
    FILE_ATTRIBUTE_SYSTEM = &H4
    FILE_ATTRIBUTE_DIRECTORY = &H10
    FILE_ATTRIBUTE_ARCHIVE = &H20
    FILE_ATTRIBUTE_NORMAL = &H80
    FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum

Private Const MAX_PATH = 260&
Private Const INVALID_HANDLE_VALUE = -1&

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Private mlngFileCount As Long
Private mudtFiles() As FILEINFO
Private mstrFolderPath As String
Private mstrExtension As String
Private mstrSearchLike As String
Private mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean

Friend Property Get Files(lngIndex As Long) As FILEINFO
    Files = mudtFiles(lngIndex)
End Property

Friend Property Get FileCount() As Long
    FileCount = mlngFileCount
End Property

Friend Property Let FolderPath(strFolderPath As String)
    mstrFolderPath = strFolderPath
End Property

Friend Property Let Extension(strExtension As String)
    mstrExtension = strExtension
End Property

Friend Property Let SearchLike(strSearchLike As String)
    mstrSearchLike = strSearchLike
End Property

Friend Property Let SubFolders(blnSubFolders As Boolean)
    mblnSubFolders = blnSubFolders
End Property

Friend Property Let CaseSenstiv(blnCaseSenstiv As Boolean)
    mblnCaseSenstiv = blnCaseSenstiv
End Property

Friend Function Execute(Optional enmSortBy As SORT_BY = Sort_by_None, _
    Optional enmSortOrder As SORT_ORDER = Sort_Order_Ascending) As Long
    Call FindFiles(mstrFolderPath)
    If mlngFileCount > 1 And enmSortBy <> Sort_by_None Then _
        Call prcSort(1, mlngFileCount, enmSortBy, enmSortOrder)
    Execute = mlngFileCount
End Function

Private Sub FindFiles(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    On Error GoTo ErrorHandling
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Call GetFilesInFolder(strFolderPath)
        If mblnSubFolders Then
            Do
                If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                    strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
                    If (strDirName <> ".") And (strDirName <> "..") Then _
                        Call FindFiles(strFolderPath & strDirName)
                End If
            Loop While FindNextFile(lngSearch, WFD)
        End If
        FindClose lngSearch
    End If
    Exit Sub
ErrorHandling:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler"
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFilename As String
    Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME
    On Error GoTo ErrorHandling
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & mstrExtension, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFilename = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
                If IIf(mblnCaseSenstiv, strFilename, LCase$(strFilename)) Like _
                    IIf(mblnCaseSenstiv, mstrSearchLike, LCase$(mstrSearchLike)) Then
                    mlngFileCount = mlngFileCount + 1
                    ReDim Preserve mudtFiles(1 To mlngFileCount)
                    With mudtFiles(mlngFileCount)
                        .strPath = strFolderPath & strFilename
                        .strFilename = strFilename
                        .lngSize = WFD.nFileSizeLow
                        FileTimeToLocalFileTime WFD.ftCreationTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtDateCreate = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                        FileTimeToLocalFileTime WFD.ftLastAccessTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtLastAccess = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                        FileTimeToLocalFileTime WFD.ftLastWriteTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtLastModify = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                    End With
                End If
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
    Exit Sub
ErrorHandling:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler"
End Sub

Private Sub prcSort(lngLBorder As Long, lngUBorder As Long, enmSortBy As SORT_BY, enmSortOrder As SORT_ORDER)
    Dim lngIndex1 As Long, lngIndex2 As Long
    Dim udtBuffer As FILEINFO, vntTemp As Variant
   
    lngIndex1 = lngLBorder
    lngIndex2 = lngUBorder
    Select Case enmSortBy
      Case Sort_by_Name: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strFileName
      Case Sort_by_Path: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strPath
      Case Sort_by_Size: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).lngSize
      Case Sort_by_Last_Access: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastAccess
      Case Sort_by_Last_Modyfy: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastModify
      Case Sort_by_Date_Create: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtDateCreate
    End Select
    Do
        Select Case enmSortBy
          Case Sort_by_Name
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).strFileName < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).strFileName
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).strFileName > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).strFileName
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Path
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).strPath < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).strPath
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).strPath > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).strPath
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Size
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).lngSize < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).lngSize
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).lngSize > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).lngSize
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Last_Access
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).dmtLastAccess < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).dmtLastAccess
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).dmtLastAccess > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).dmtLastAccess
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Last_Modyfy
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).dmtLastModify < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).dmtLastModify
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).dmtLastModify > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).dmtLastModify
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Date_Create
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).dmtDateCreate < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).dmtDateCreate
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).dmtDateCreate > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).dmtDateCreate
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
        End Select
        If lngIndex1 <= lngIndex2 Then
            udtBuffer = mudtFiles(lngIndex1)
            mudtFiles(lngIndex1) = mudtFiles(lngIndex2)
            mudtFiles(lngIndex2) = udtBuffer
            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1
        End If
    Loop Until lngIndex1 > lngIndex2
    If lngLBorder < lngIndex2 Then Call prcSort(lngLBorder, lngIndex2, enmSortBy, enmSortOrder)
    If lngIndex1 < lngUBorder Then Call prcSort(lngIndex1, lngUBorder, enmSortBy, enmSortOrder)
End Sub

Es ist mir aber nicht möglich, die Alternative umzusetzen.
Jetzt hoffe ich, du hast die Zeit und Interesse, mir hierbei nochmals zu helfen.


mfg chooka

 

Hallo chooka

Es freut mich, dass meine damalige Hilfe so lange nützlich war... aber leider nein, ich kann Dir nicht mehr helfen.

Da in Excel2007, und erst recht in 2010, nicht nur neue Funktionen sind, sondern (wohl selten gebrauchte) Funktionen aus Excel2003 auch entfernt wurden, hätte ich alle meine eigenen, sehr aufwändigen Makros umschreiben müssen.
Schon der Umstieg auf Win7 hatte einige Hilfsprogramme ausser Gefecht gesetzt. So musste ich zB eine DLL nach VBA "übersetzen" und dazu zuerst einmal in die sphärische Trigonometrie einsteigen... brrrh.

Ich bleibe deshalb bei Win7 und Excel2003 - ein Umstieg lohnt sich nicht mehr...

Neue VBA-Lösungen kann ich aber so nicht für höhere Excel-Versionen entwerfen, ich kann meine Ideen ja nicht testen.

Ich schaue zwar oft hier vorbei, aber beteiligen kann ich mich nur noch in Ausnahmefällen.
Sorry !

Gruss

Urs - VBA-Helfer a.D.

 

Hi Urs2,
danke für die Mitteilung. Hatte schon damit gerechnet, und wäre auch viel verlangt gewesen. Vielleicht findet sich noch jemand anderes, der dein grandioses Makro etwas umschreiben kann.
Gruß chooka