File search in new excel

[Slomaro2000]

Hello,
I have been trying to get this macro to work with the new version of excel. I have researching it and can't get it to work correctly for some reason. Maybe I have been looking at this computer for too long or something.

Could someone please help me out that would be GREAT.

Thanks, J

Sub x()
Application.ScreenUpdating = False
Dim response As Long
    response = MsgBox(prompt:="Are you sure you want to Convert/Format all of Excel files in the folder?", Buttons:=4)
    If response = 7 Then Exit Sub
    
 
 
 
With Application.FileSearch
.LookIn = "C:\Users\U369875\Desktop\Project stuff\Testin Save_AS"
.Filename = ".xls"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set newwkbk = ActiveWorkbook
For i = 1 To .FoundFiles.Count
Set wkbk = Workbooks.Open(.FoundFiles(i))
Temp = wkbk.Name
 
 


Call Macro2
Call Macro3
Call Save_To_Directory

Application.StatusBar = "workbook " & i & "  of " & .FoundFiles.Count
Next i
End If
End With

MsgBox "All files have been Formatted"
End Sub

 

[Kenneth Hobson]

That macro stopped working in the old version 2007 because Application.FileSearch was dropped.

If you want to use something similar, insert a class named FileSearch and paste this code. It also has another class method in the first comments.

Otherwise, you will need to use a Dir(), filesystem object, or DOS method.

'Other class method:
'ginismo, http://www.mrexcel.com/forum/showthread.php?t=369982  'Class method
  'http://www.mrexcel.com/forum/showthread.php?p=1839452
  'http://www.4shared.com/file/87591234/8d1d705d/1839452_classFileSearch_and_Excel4.html
'http://www.mrexcel.com/forum/showthread.php?p=2551004 'alternate class method
'http://dl.dropbox.com/u/35239054/FileSearch.cls 'alternate class method by Andreas Killer, version 1.43


'Version 1.43
'Andreas Killer
'http://dl.dropbox.com/u/35239054/FileSearch.cls
'20.07.11
'Attribute VB_Name = "FileSearch"

'Nachbildung des FileSearch-Objektes für MS-Office
'Property-Tests sind nicht implementiert!

Option Explicit
Option Compare Text

#Const UseNewOfficeFileExtensions = False

Public Event BeforeSearchFolder(ByVal Path As String, ByRef Cancel As Boolean)

Public Enum msoSortBy
  msoSortByFileName = 1
  msoSortBySize = 2
  msoSortByFileType = 3
  msoSortByLastModified = 4
End Enum

Public Enum msoFileType
  msoFileTypeAllFiles = 1
  msoFileTypeOfficeFiles = 2
  msoFileTypeWordDocuments = 3
  msoFileTypeExcelWorkbooks = 4
  msoFileTypePowerPointPresentations = 5
  msoFileTypeBinders = 6
  msoFileTypeDatabases = 7
  msoFileTypeTemplates = 8
End Enum

Public Enum msoLastModified
  msoLastModifiedYesterday = 1
  msoLastModifiedToday = 2
  msoLastModifiedLastWeek = 3
  msoLastModifiedThisWeek = 4
  msoLastModifiedLastMonth = 5
  msoLastModifiedThisMonth = 6
  msoLastModifiedAnyTime = 7
End Enum

Public SearchSubFolders As Boolean
Public FoundFiles As Collection
Public FoundDirs As Collection

Private fsFileName As Variant
Private fsFileExt As Variant
Private fsFileBase As Variant
Private fsLookIn As String
Private fsFileType As msoFileType
Private fsLastModified As msoLastModified

Private SortFiles As Collection
Private SortDirs As Collection
Private SortFilesBy As msoSortBy
Private fso As Object 'FileSystemObject

Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
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 Const FIND_FIRST_EX_CASE_SENSITIVE As Long = 1
'MSDN: "This value is not supported until Windows Server 2008 R2 and Windows 7."
Private Const FIND_FIRST_EX_LARGE_FETCH As Long = 2

Private Enum FINDEX_SEARCH_OPS
  FindExSearchNameMatch
  FindExSearchLimitToDirectories
  FindExSearchLimitToDevices
End Enum

Private Enum FINDEX_INFO_LEVELS
  FindExInfoStandard
  FindExInfoBasic 'MSDN: "This value is not supported until Windows Server 2008 R2 and Windows 7."
  FindExInfoMaxInfoLevel
End Enum

Private Declare Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExA" ( _
ByVal lpFileName As String, ByVal fInfoLevelId As Long, lpFindFileData As WIN32_FIND_DATA, _
    ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal dwAdditionalFlags As Long) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

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 Declare Function FileTimeToSystemTime Lib "kernel32" ( _
    lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpDest As Any, lpSource As Any, ByVal nCount As Long)

Private Sub Class_Initialize()
  Set FoundDirs = New Collection
  Set FoundFiles = New Collection
  Set SortFiles = New Collection
  Set SortDirs = New Collection
  Set fso = CreateObject("Scripting.FileSystemObject")
  FileType = msoFileTypeOfficeFiles
  LastModified = msoLastModifiedAnyTime
End Sub

Private Sub Class_Terminate()
  Set FoundDirs = Nothing
  Set FoundFiles = Nothing
  Set SortFiles = Nothing
  Set SortDirs = Nothing
  Set fso = Nothing
End Sub

Public Sub NewSearch()
  Filename = ""
  fsLookIn = ""
  FileType = msoFileTypeOfficeFiles
  LastModified = msoLastModifiedAnyTime
  SearchSubFolders = False
  ClearCollections
End Sub

Private Sub ClearCollections()
  If FoundFiles.Count > 0 Then
    Set FoundFiles = Nothing
    Set FoundFiles = New Collection
    Set SortFiles = Nothing
    Set SortFiles = New Collection
  End If
  If FoundDirs.Count > 0 Then
    Set FoundDirs = Nothing
    Set FoundDirs = New Collection
    Set SortDirs = Nothing
    Set SortDirs = New Collection
  End If
End Sub

Property Let Filename(Value As Variant)
  If IsArray(Value) Then
    fsFileName = Value
  Else
    fsFileName = Array(Value)
  End If
  fsFileType = 0
End Property

Property Get Filename() As Variant
  Filename = Join(fsFileName, ", ")
End Property

Property Let FileType(Value As msoFileType)
  fsFileType = Value
#If UseNewOfficeFileExtensions Then
  Select Case Value
    Case msoFileTypeAllFiles
      fsFileName = Array("*.*")
    Case msoFileTypeOfficeFiles
      fsFileName = Array( _
        "*.doc", "*.docm", "*.docx", "*.dot", "*.dotm", "*.dotx", _
        "*.htm", "*.html", _
        "*.mdb", "*.mdbm", "*.mdbx", "*.mpd", "*.mpdm", "*.mpdx", _
        "*.obd", "*.obdm", "*.obdx", "*.obt", "*.obtm", "*.obtx", _
        "*.pot", "*.potm", "*.potx", "*.pps", "*.ppsm", "*.ppsx", "*.ppt", "*.pptm", "*.pptx", _
        "*.xls", "*.xlsm", "*.xlsx", "*.xlt", "*.xltm", "*.xltx")
    Case msoFileTypeWordDocuments
      fsFileName = Array("*.doc", "*.docm", "*.docx", "*.htm", "*.html")
    Case msoFileTypeExcelWorkbooks
      fsFileName = Array("*.xls", "*.xlsm", "*.xlsx")
    Case msoFileTypePowerPointPresentations
      fsFileName = Array("*.pps", "*.ppsm", "*.ppsx", "*.ppt", "*.pptm", "*.pptx")
    Case msoFileTypeBinders
      fsFileName = Array("*.obd", "*.obdm", "*.obdx")
    Case msoFileTypeDatabases
      fsFileName = Array("*.mdb", "*.mdbm", "*.mdbx", "*.mpd", "*.mpdm", "*.mpdx")
    Case msoFileTypeTemplates
      fsFileName = Array( _
        "*.dot", "*.dotm", "*.dotx", _
        "*.obt", "*.obtm", "*.obtx", _
        "*.pot", "*.potm", "*.potx", _
        "*.xlt", "*.xltm", "*.xltx")
    Case Else
      fsFileType = 0
      fsFileName = Array("*.*")
  End Select
#Else
  Select Case Value
    Case msoFileTypeAllFiles
      fsFileName = Array("*.*")
    Case msoFileTypeOfficeFiles
      fsFileName = Array("*.doc", "*.dot", "*.htm", "*.html", "*.mdb", "*.mpd", "*.obd", "*.obt", _
        "*.pot", "*.pps", "*.ppt", "*.xls", "*.xlt")
    Case msoFileTypeWordDocuments
      fsFileName = Array("*.doc", "*.htm", "*.html")
    Case msoFileTypeExcelWorkbooks
      fsFileName = Array("*.xls")
    Case msoFileTypePowerPointPresentations
      fsFileName = Array("*.pps", "*.ppt")
    Case msoFileTypeBinders
      fsFileName = Array("*.obd")
    Case msoFileTypeDatabases
      fsFileName = Array("*.mdb", "*.mpd")
    Case msoFileTypeTemplates
      fsFileName = Array("*.dot", "*.obt", "*.pot", "*.xlt")
    Case Else
      fsFileType = 0
      fsFileName = Array("*.*")
  End Select
#End If
End Property

Property Get FileType() As msoFileType
  FileType = fsFileType
End Property

Property Let LastModified(Value As msoLastModified)
  If Value >= 1 And Value <= 7 Then
    fsLastModified = Value
  Else
    fsLastModified = msoLastModifiedAnyTime
  End If
End Property

Property Get LastModified() As msoLastModified
  LastModified = fsLastModified
End Property

Property Let LookIn(ByVal Value As String)
  fsLookIn = fso.BuildPath(fso.GetAbsolutePathName(Value), "\")
End Property

Property Get LookIn() As String
  LookIn = fsLookIn
End Property

Private Function MakeDecimal(ByVal Lo As Long, ByVal Hi As Long, _
    Optional ByVal wEx As Long = 0, _
    Optional Minus As Boolean = False) As Variant
  If Minus Then MakeDecimal = CDec(-1) Else MakeDecimal = CDec(1)
  CopyMemory ByVal VarPtr(MakeDecimal) + 8, Lo, 4
  CopyMemory ByVal VarPtr(MakeDecimal) + 12, Hi, 4
  If wEx <> 0 Then CopyMemory ByVal VarPtr(MakeDecimal) + 4, Lo, 4
End Function

Private Function FirstWeek(ByVal Datum As Date) As Date
  'Liefert den 1. Tag der Woche in dem Datum liegt
  FirstWeek = Datum - Weekday(Datum, vbUseSystemDayOfWeek) + 1
End Function

Private Sub SearchPrim(ByVal Path As String)
  Dim hFindFile As Long, hFoundFile As WIN32_FIND_DATA
  Dim FName As String
  Dim STime As SYSTEMTIME
  Dim FTime As Date, ETime As Date, LTime As Date
  Dim i As Integer, j As Long
  Dim AddIt As Boolean, Cancel As Boolean

  If fsLastModified <> msoLastModifiedAnyTime Then
    Select Case fsLastModified
      Case msoLastModifiedYesterday
        ETime = Date - 1
        LTime = Date - 1
      Case msoLastModifiedToday
        ETime = Date
        LTime = Date
      Case msoLastModifiedLastWeek
        ETime = FirstWeek(Date) - 7
        LTime = ETime + 6
      Case msoLastModifiedThisWeek
        ETime = FirstWeek(Date)
        LTime = ETime + 6
      Case msoLastModifiedLastMonth
        ETime = DateSerial(Year(Date), Month(Date) - 1, 1)
        LTime = DateSerial(Year(Date), Month(Date), 0)
      Case msoLastModifiedThisMonth
        ETime = DateSerial(Year(Date), Month(Date), 1)
        LTime = DateSerial(Year(Date), Month(Date) + 1, 0)
    End Select
  End If

  'Suche nach den Dateien
  For i = LBound(fsFileName) To UBound(fsFileName)
    hFindFile = FindFirstFileEx(Path & fsFileName(i) & vbNullChar, _
      FindExInfoStandard&, hFoundFile, FindExSearchNameMatch&, 0&, 0&)
    If hFindFile <> INVALID_HANDLE_VALUE Then
      Do
        With hFoundFile
          'Die Verzeichnisse ausschließen
          If (.dwFileAttributes And vbDirectory) = 0 Then
            If fsLastModified = msoLastModifiedAnyTime Then
              AddIt = True
            Else
              'Konvertiere Dateizeit zu Systemzeit
              FileTimeToSystemTime .ftLastWriteTime, STime
              'Generiere VBA-Datum
              With STime
                FTime = DateSerial(.wYear, .wMonth, .wDay)
              End With
              AddIt = FTime >= ETime And FTime <= LTime
            End If

            If AddIt Then
              j = InStr(.cFileName, vbNullChar) - 1
              FName = Mid$(.cFileName, 1, j)
              If j - InStrRev(FName, ".") > 3 Then
                'Problem *.htm findet auch *.html
                AddIt = fso.GetExtensionName(FName) Like fsFileExt(i) And _
                  fso.GetBaseName(FName) Like fsFileBase(i)
              End If
            End If

            If AddIt Then
              FoundFiles.Add Path & FName

              'Sollen wir sortieren?
              Select Case SortFilesBy
                Case msoSortByFileName
                  'Pfad, dann Name
                  SortFiles.Add FName & Path
                Case msoSortByFileType
                  'Extension, dann Pfad, dann Name
                  SortFiles.Add fso.GetExtensionName(FName) & Path & FName
                Case msoSortByLastModified
                  'Konvertiere Dateizeit zu Systemzeit
                  FileTimeToSystemTime .ftLastWriteTime, STime
                  'Generiere VBA-Datum
                  With STime
                    FTime = DateSerial(.wYear, .wMonth, .wDay) + _
                      TimeSerial(.wHour, .wMinute, .wSecond)
                  End With
                  SortFiles.Add FTime
                Case msoSortBySize
                  SortFiles.Add MakeDecimal(.nFileSizeLow, .nFileSizeHigh)
              End Select
            End If
          Else
            If fsLastModified = msoLastModifiedAnyTime Then
              AddIt = True
            Else
              'Konvertiere Dateizeit zu Systemzeit
              FileTimeToSystemTime .ftLastWriteTime, STime
              'Generiere VBA-Datum
              With STime
                FTime = DateSerial(.wYear, .wMonth, .wDay)
              End With
              AddIt = FTime >= ETime And FTime <= LTime
            End If

            If AddIt Then
              'Problem Verzeichnisse "." und ".." ausschließen, aber alle anderen zulassen (.borland)
              AddIt = InStr(.cAlternate, vbNullChar) > 1
              If Not AddIt Then
                For j = 1 To Len(.cFileName)
                  Select Case Mid$(.cFileName, j, 1)
                    Case "."
                    Case vbNullChar
                      Exit For
                    Case Else
                      AddIt = True
                      Exit For
                  End Select
                Next
              End If
            End If

            If AddIt Then
              FName = Mid$(.cFileName, 1, InStr(.cFileName, vbNullChar) - 1)
              If InStr(FName, "?") > 0 Then
                'Problem Verzeichnisse mit ungültigen Zeichen "??sortierte Lesezeichen"
                FName = Mid$(.cAlternate, 1, InStr(.cAlternate, vbNullChar) - 1)
              End If
              FoundDirs.Add Path & FName

              'Sollen wir sortieren?
              Select Case SortFilesBy
                Case msoSortByFileName
                  'Pfad
                  SortDirs.Add Path & FName
                Case msoSortByFileType
                  'Extension, dann Pfad, dann Name
                  SortDirs.Add fso.GetExtensionName(FName) & Path & FName
                Case msoSortByLastModified
                  'Konvertiere Dateizeit zu Systemzeit
                  FileTimeToSystemTime .ftLastWriteTime, STime
                  'Generiere VBA-Datum
                  With STime
                    FTime = DateSerial(.wYear, .wMonth, .wDay) + _
                      TimeSerial(.wHour, .wMinute, .wSecond)
                  End With
                  SortDirs.Add FTime
                Case msoSortBySize
                  SortDirs.Add MakeDecimal(.nFileSizeLow, .nFileSizeHigh)
              End Select
            End If
          End If
        End With
      Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
      FindClose hFindFile
    End If
  Next

  If SearchSubFolders Then
    'Suche nach einem Verzeichnis
    'Problem "*." findet keine Verzeichnisse die einen Punkt enthalten!
    hFindFile = FindFirstFileEx(Path & "*" & vbNullChar, _
      FindExInfoStandard&, hFoundFile, FindExSearchLimitToDirectories&, 0&, 0&)
    If hFindFile <> INVALID_HANDLE_VALUE Then
      Do
        With hFoundFile
          If (.dwFileAttributes And vbDirectory) > 0 Then
            'Problem Verzeichnisse "." und ".." ausschließen, aber alle anderen zulassen (.borland)
            AddIt = InStr(.cAlternate, vbNullChar) > 1
            If Not AddIt Then
              'AddIt = Left$(.cFileName, 1) <> "."
              For j = 1 To Len(.cFileName)
                Select Case Mid$(.cFileName, j, 1)
                  Case "."
                  Case vbNullChar
                    Exit For
                  Case Else
                    AddIt = True
                    Exit For
                End Select
              Next
            End If

            If AddIt Then
              FName = Mid$(.cFileName, 1, InStr(.cFileName, vbNullChar) - 1)
              If InStr(FName, "?") > 0 Then
                'Problem Verzeichnisse mit ungültigen Zeichen "??sortierte Lesezeichen"
                FName = Mid$(.cAlternate, 1, InStr(.cAlternate, vbNullChar) - 1)
              End If
              Cancel = False
              RaiseEvent BeforeSearchFolder(Path & FName, Cancel)
              'Starte rekursive Suche
              If Not Cancel Then SearchPrim Path & FName & "\"
            End If
          End If
        End With
      Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
      FindClose hFindFile
    End If
  End If
End Sub

Private Sub QuickSortCollection(ByRef Liste As Collection, ByRef Data As Collection, _
    Optional ByVal Compare As VbCompareMethod = vbDatabaseCompare, _
    Optional ByVal SortOrder As MsoSortOrder = msoSortOrderAscending)
  'Sortiert eine Collection mit beliebigen Werten, führt eine zweite Collection parallel mit
  Const QTHRESH As Long = 9
  Dim i As Long, j As Long, C As Integer, Ci As Integer, Cj As Integer
  Dim Pivot, Temp
  Dim DArr(), LArr()
  Dim DoResume As Boolean
  Dim Stack(1 To 64) As Long
  Dim StackPtr As Long
  Dim Start As Long, Ende As Long

  'Wir brauchen mind. 2 Elemente
  If Liste.Count < 2 Then Exit Sub

  'Daten aus der Collection in ein Array übertragen
  ReDim LArr(1 To Liste.Count)
  ReDim DArr(1 To Liste.Count)
  i = 0
  For Each Temp In Liste
    i = i + 1
    LArr(i) = Temp
  Next
  i = 0
  For Each Temp In Data
    i = i + 1
    DArr(i) = Temp
  Next

  Start = 1
  Ende = UBound(LArr)
  If SortOrder = msoSortOrderAscending Then C = 1 Else C = -1
  Ci = 1

  Stack(StackPtr + 1) = Start
  Stack(StackPtr + 2) = Ende
  StackPtr = StackPtr + 2

  Do
    StackPtr = StackPtr - 2
    Start = Stack(StackPtr + 1)
    Ende = Stack(StackPtr + 2)

    If Ende - Start < QTHRESH Then
      'Insertionsort
      Select Case Compare
        Case vbDatabaseCompare
          'Zahlen sortieren
          If SortOrder = msoSortOrderAscending Then
            For j = Start + 1 To Ende
              Pivot = LArr(j)
              Temp = DArr(j)
              For i = j - 1 To Start Step -1
                If DArr(i) <= Pivot Then Exit For
                LArr(i + 1) = LArr(i)
                DArr(i + 1) = DArr(i)
              Next
              LArr(i + 1) = Pivot
              DArr(i + 1) = Temp
            Next
          Else
            For j = Start + 1 To Ende
              Pivot = LArr(j)
              Temp = DArr(j)
              For i = j - 1 To Start Step -1
                If LArr(i) >= Pivot Then Exit For
                LArr(i + 1) = LArr(i)
                DArr(i + 1) = DArr(i)
              Next
              LArr(i + 1) = Pivot
              DArr(i + 1) = Temp
            Next
          End If

        Case vbTextCompare
          'Texte sortieren => MatchCase:=False
          For j = Start + 1 To Ende
            Pivot = LArr(j)
            Temp = DArr(j)
            For i = j - 1 To Start Step -1
              Ci = StrComp(LArr(i), Pivot, Compare)
              If Ci <> C Then Exit For
              LArr(i + 1) = LArr(i)
              DArr(i + 1) = DArr(i)
            Next
            LArr(i + 1) = Pivot
            DArr(i + 1) = Temp
          Next
      End Select
    Else
      'QuickSort
      i = Start: j = Ende
      Pivot = LArr((Start + Ende) \ 2)
      Do
        Select Case Compare
          Case vbDatabaseCompare
            'Zahlen sortieren
            If SortOrder = msoSortOrderAscending Then
              Do While (LArr(i) < Pivot): i = i + 1: Loop
              Do While (LArr(j) > Pivot): j = j - 1: Loop
            Else
              Do While (LArr(i) > Pivot): i = i + 1: Loop
              Do While (LArr(j) < Pivot): j = j - 1: Loop
            End If

          Case vbTextCompare
            'Texte sortieren => MatchCase:=False
            Ci = StrComp(LArr(i), Pivot, Compare)
            Do While (Ci = -C)
              i = i + 1
              Ci = StrComp(LArr(i), Pivot, Compare)
            Loop
            Cj = StrComp(LArr(j), Pivot, Compare)
            Do While (Cj = C)
              j = j - 1
              Cj = StrComp(LArr(j), Pivot, Compare)
            Loop
        End Select

        If i <= j Then
          If i < j And Not (Ci = 0 And Cj = 0) Then
            Temp = DArr(i)
            DArr(i) = DArr(j)
            DArr(j) = Temp
            Temp = LArr(i)
            LArr(i) = LArr(j)
            LArr(j) = Temp
          End If
          i = i + 1: j = j - 1
        End If
      Loop Until i > j

      If (Start < j) Then
        'QuickSort LArr, Start, j, Compare, SortOrder
        Stack(StackPtr + 1) = Start
        Stack(StackPtr + 2) = j
        StackPtr = StackPtr + 2
      End If
      If (i < Ende) Then
        'QuickSort LArr, i, Ende, Compare, SortOrder
        Stack(StackPtr + 1) = i
        Stack(StackPtr + 2) = Ende
        StackPtr = StackPtr + 2
      End If
    End If
  Loop Until StackPtr = 0

  'Collection neu aufbauen
  Set Data = Nothing
  Set Data = New Collection
  For i = 1 To UBound(DArr)
    Data.Add DArr(i)
  Next
End Sub

Public Function Execute( _
    Optional SortBy As msoSortBy = 0, _
    Optional SortOrder As MsoSortOrder = msoSortOrderAscending, _
    Optional AlwaysAccurate As Boolean = True) As Long
  'Beginnt die Suche nach den angegebenen Dateien.
  'SortBy:
  '  Die für die Sortierung der zurückgegebenen Dateien verwendete Methode. Dies kann eine der _
    folgenden MsoSortBy- Konstanten sein: msoSortbyFileName, msoSortbyFileType, _
    msoSortbyLastModified oder msoSortbySize. Ist SortBy = 0 wird nicht sortiert
  'SortOrder:
  '  Die Reihenfolge, in der die zurückgegebenen Dateien sortiert werden sollen. Dies kann eine _
der folgenden MsoSortOrder-Konstanten sein: msoSortOrderAscending oder msoSortOrderDescending.
  'AlwaysAccurate:
  '  Ohne Funktion, nur aus Kompatiblitätsgründen

  Dim i As Integer
  ReDim fsFileExt(LBound(fsFileName) To UBound(fsFileName))
  ReDim fsFileBase(LBound(fsFileName) To UBound(fsFileName))
  For i = LBound(fsFileName) To UBound(fsFileName)
    fsFileExt(i) = fso.GetExtensionName(fsFileName(i))
    fsFileBase(i) = fso.GetBaseName(fsFileName(i))
  Next

  ClearCollections
  SortFilesBy = SortBy
  SearchPrim fsLookIn
  Execute = FoundFiles.Count
  Select Case SortBy
    Case msoSortByFileName, msoSortByFileType
      QuickSortCollection SortFiles, FoundFiles, vbTextCompare, SortOrder
      QuickSortCollection SortDirs, FoundDirs, vbTextCompare, SortOrder
    Case msoSortByLastModified, msoSortBySize
      QuickSortCollection SortFiles, FoundFiles, vbDatabaseCompare, SortOrder
      QuickSortCollection SortDirs, FoundDirs, vbDatabaseCompare, SortOrder
  End Select
End Function

 

[Slomaro2000]

What do you think the best and easiest way is?


I have no clue what all that code is doing.




How would I get that code going with the Dir(), filesystem object, or DOS method?

 

[Kenneth Hobson]

I have posted the other methods as have others. I gave the best and easiest method. You don't have to know the code in the class to use it. It was designed to be similar to the Application.FileSearch. Try using it as you did in your code which is why I posted it for you. Otherwise, you have to change your code to fit the other methods.

I would recommend that your first line of code be Option Explicit.

 

[Slomaro2000]

I have never added a "class module" before.

I added it put "FileSearch" at top to name it




I try to run and get a "Compile error - Invalid outside procedure".

 

[Kenneth Hobson]

Like adding a Module, using the menu method in VBE to add a class, Insert > Class Module. You then change the Name property by View > Properties Window. Then change the value of (Name) from Class1 to FileSearch.

Of course you could import the CLS file after you download it from the link that I provided. After downloading, File > Import File, and navigate to where you downloaded it to.

While I did show how to use a similar class in the commented links at the beginning, here is how to use this class which is very similar. Notice that we Dim it and set a New instance and then use that reference rather than the non-existent Application.FileSearch. Note how it works from then on in a similar fashion, ergo why I posted it for you.

Option Explicit

Sub Test_FileSearchClass()
  Dim i As Long, fs As FileSearch
  Set fs = New FileSearch
  With fs
    '.LookIn = "C:\Users\U369875\Desktop\Project stuff\Testin Save_AS"
    .LookIn = ThisWorkbook.Path
    .Filename = ".xls"
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    If .Execute() <= 0 Then Exit Sub
    For i = 1 To .FoundFiles.Count
      Debug.Print .FoundFiles(i)
    Next i
  End With
End Sub

 

[Kenneth Hobson]

Since you are not iterating subfolders, the Dir() method can be used.

e.g.

Sub DirFiles()
    Dim FileName As String, FileSpec As String, FileFolder As String
    Dim wb As Workbook
    
    FileFolder = ThisWorkbook.Path & "\"
    FileSpec = FileFolder & "*.xl*"
    
    FileName = Dir(FileSpec)
    If FileName = "" Then Exit Sub
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        If IsWorkbookOpen(FileName) = False Then
          Set wb = Workbooks.Add(FileFolder & FileName)
          DoEvents
          wb.Close True
        End If
        FileName = Dir()
    Loop

End Sub

 

[Slomaro2000]

Kenneth,
I tried this and get a "Compile Error" marked below.

Since you are not iterating subfolders, the Dir() method can be used.

e.g.

Sub DirFiles()
    Dim FileName As String, FileSpec As String, FileFolder As String
    Dim wb As Workbook
 
    FileFolder = ThisWorkbook.Path & "\"
    FileSpec = FileFolder & "*.xl*"
 
    FileName = Dir(FileSpec)
    If FileName = "" Then Exit Sub
 
'   Loop until no more matching files are found
    Do While FileName <> ""
        If [COLOR=red][B]IsWorkbookOpen[/B][/COLOR](FileName) = False Then
          Set wb = Workbooks.Add(FileFolder & FileName)
          DoEvents
          wb.Close True
        End If
        FileName = Dir()
    Loop
 
End Sub

 

[Kenneth Hobson]

That is a function that I use. It is not needed to illustrate the Dir() method.

Sub DirFiles()
    Dim FileName As String, FileSpec As String, FileFolder As String
 
    FileFolder = ThisWorkbook.Path & "\"
    FileSpec = FileFolder & "*.xl*"
 
    FileName = Dir(FileSpec)
    If FileName = "" Then Exit Sub
 
'   Loop until no more matching files are found
    Do While FileName <> ""
        Debug.Print FileName
        FileName = Dir()
    Loop
End Sub

IF you really wanted it, you could have searched the forum.

Function IsWorkbookOpen(stName As String) As Boolean
    Dim Wkb As Workbook
    On Error Resume Next ' In Case it isn't Open
    Set Wkb = Workbooks(stName)
    If Not Wkb Is Nothing Then IsWorkbookOpen = True
    'Boolean Function assumed To be False unless Set To True
End Function