locked
Replacing the Application.FileSearch RRS feed

  • Question

  • Can some please help me with replacing the Application.FileSearch function with the new methode in MS Excel 2010?

    Sub getData()
        Dim wbTemp As Workbook
        Dim wsTemp, wsDest, wsData, wsTime As Worksheet
       
        Set wsDataDest = ActiveWorkbook.Sheets("MI_Data")
        Set wsTimeDest = ActiveWorkbook.Sheets("MI_Timeout")
       
        wbPath = ActiveWorkbook.Path
        fldrPath = wbPath & "\Data Files"
       
        wsDataDest.Range("A2:AL65000").ClearContents
        wsTimeDest.Range("A2:F65000").ClearContents
       
          
        With Application.FileSearch
            .NewSearch
            .LookIn = fldrPath
            .Filename = "*.xls"
            .SearchSubFolders = False
            .Execute
           
            file_count = .FoundFiles.Count
       
            For i = 1 To file_count
                Application.ScreenUpdating = False
                Set wbTemp = Application.Workbooks.Open(.FoundFiles(i))
                wbTemp.Sheets("Data").Visible = xlSheetVisible
                wbTemp.Sheets("Timeout").Visible = xlSheetVisible
               
                Set wsData = wbTemp.Sheets("Data")
                Set wsTime = wbTemp.Sheets("Timeout")
               
                dRec = wsData.Cells(1, 1).End(xlDown).Row
                tRec = wsTime.Cells(1, 1).End(xlDown).Row
               
                dRwInd = wsDataDest.Cells(1, 1).End(xlDown).Row + 1
                tRwInd = wsTimeDest.Cells(1, 1).End(xlDown).Row + 1
               
               
                If dRec > 65000 Then
                    dRec = 2
                End If
               
                If tRec > 65000 Then
                    tRec = 2
                End If
               
                If dRwInd > 65000 Then
                    dRwInd = 2
                End If
               
                If tRwInd > 65000 Then
                    tRwInd = 2
                End If
               
    '            If wsData.Cells(2, 4) = "" Then
    '                memName = Mid(.FoundFiles(i), x - 8, 2)
    '            Else
                    memName = wsData.Cells(2, 4)
    '            End If
               
    '            x = Len(.FoundFiles(i))
    '            wsDest.Cells(i + 1, 1) = memName
    '            wsDest.Cells(i + 1, 2) = Mid(.FoundFiles(i), 1, x)
               
                rData = "A2:AI" & dRec
                tData = "A2:F" & tRec
               
                wsData.Range(rData).Copy
                q = "A" & dRwInd
                wsDataDest.Range(q).PasteSpecial
                Application.CutCopyMode = False
               
                wsTime.Range(tData).Copy
                q = "B" & tRwInd
                wsTimeDest.Range(q).PasteSpecial
                Application.CutCopyMode = False
                For j = tRwInd To (tRwInd + tRec) - 2
                    wsTimeDest.Cells(j, 1) = memName
                Next j
               
    '           tempWS.Range("J6:J16").Copy
    '           wsDest.Range("B" & (i + 1)).PasteSpecial Paste:=xlPasteValues, Transpose:=True
              
                wbTemp.Sheets("Data").Visible = xlSheetVeryHidden
                wbTemp.Sheets("Timeout").Visible = xlSheetVeryHidden
                wbTemp.Close (False)
                Application.ScreenUpdating = True
            Next i
       
        End With
       
        MsgBox ("Data from " & file_count & " files successfully updated.")
           
        calReso

    End Sub

    Friday, February 21, 2014 10:05 AM

Answers

  • Okay I did not see that you have to use the file later in the code. I thought you only wanted the File Count. That would change things. Okay. Lets do something about this. Scratch the code I gave before, replace it with the following.

    Function getFolderList(fPath As String, Optional filtStr As String = "*.*") As String
    '**********************
    'Code Courtesy of
    '  Paul Eugin
    '**********************
        Dim tmpPath As String, fList As String
        If Right$(fPath, 1) <> "\" Then fPath = fPath & "\"
        tmpPath = Dir(fPath & filtStr)
        If tmpPath = "" Then
            getFolderList = vbNullString
            Exit Function
        End If
        fList = fList & tmpPath & "|"
        Do
            tmpPath = Dir
            If tmpPath = "" Then Exit Do
            fList = fList & tmpPath & "|"
        Loop
        getFolderList = Left(fList, Len(fList) - 1)
    End Function

    Then, your modified code as,

    Sub getData()
        Dim wbTemp As Workbook, fileArr() As String
        Dim wsTemp, wsDest, wsData, wsTime As Worksheet
       
        Set wsDataDest = ActiveWorkbook.Sheets("MI_Data")
        Set wsTimeDest = ActiveWorkbook.Sheets("MI_Timeout")
       
        wbPath = ActiveWorkbook.Path
        fldrPath = wbPath & "\Data Files"
       
        wsDataDest.Range("A2:AL65000").ClearContents
        wsTimeDest.Range("A2:F65000").ClearContents
    	
    	fileArr = Split(getFolderList(fldrPath), "|")
    	file_count = UBound(fileArr)+1
       
    	For i = 1 To file_count
    		Application.ScreenUpdating = False
    		Set wbTemp = Application.Workbooks.Open(fileArr(i-1))
    		wbTemp.Sheets("Data").Visible = xlSheetVisible
    		wbTemp.Sheets("Timeout").Visible = xlSheetVisible
    	   
    		Set wsData = wbTemp.Sheets("Data")
    		Set wsTime = wbTemp.Sheets("Timeout")
    	   
    		dRec = wsData.Cells(1, 1).End(xlDown).Row
    		tRec = wsTime.Cells(1, 1).End(xlDown).Row
    	   
    		dRwInd = wsDataDest.Cells(1, 1).End(xlDown).Row + 1
    		tRwInd = wsTimeDest.Cells(1, 1).End(xlDown).Row + 1
    	   
    	   
    		If dRec > 65000 Then
    			dRec = 2
    		End If
    	   
    		If tRec > 65000 Then
    			tRec = 2
    		End If
    	   
    		If dRwInd > 65000 Then
    			dRwInd = 2
    		End If
    	   
    		If tRwInd > 65000 Then
    			tRwInd = 2
    		End If
    	   
    '            If wsData.Cells(2, 4) = "" Then
    '                memName = Mid(fileArr(i-1), x - 8, 2)
    '            Else
    			memName = wsData.Cells(2, 4)
    '            End If
    	   
    '            x = Len(fileArr(i-1))
    '            wsDest.Cells(i + 1, 1) = memName
    '            wsDest.Cells(i + 1, 2) = Mid(fileArr(i-1), 1, x)
    	   
    		rData = "A2:AI" & dRec
    		tData = "A2:F" & tRec
    	   
    		wsData.Range(rData).Copy
    		q = "A" & dRwInd
    		wsDataDest.Range(q).PasteSpecial
    		Application.CutCopyMode = False
    	   
    		wsTime.Range(tData).Copy
    		q = "B" & tRwInd
    		wsTimeDest.Range(q).PasteSpecial
    		Application.CutCopyMode = False
    		For j = tRwInd To (tRwInd + tRec) - 2
    			wsTimeDest.Cells(j, 1) = memName
    		Next j
    	   
    '           tempWS.Range("J6:J16").Copy
    '           wsDest.Range("B" & (i + 1)).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    	  
    		wbTemp.Sheets("Data").Visible = xlSheetVeryHidden
    		wbTemp.Sheets("Timeout").Visible = xlSheetVeryHidden
    		wbTemp.Close (False)
    		Application.ScreenUpdating = True
    	Next i
       
        MsgBox ("Data from " & file_count & " files successfully updated.")
           
        calReso
    End Sub


    Happy to help ! When you see answers and helpful posts, please click Vote As Helpful, Propose As Answer, and/or Mark As Answered




    Friday, February 21, 2014 12:33 PM

All replies

  • Copy the following function into a Standard module, then Save and Compile the code, then you can change the Application.FileSearch with this function.

    Function getFileCount(fPath As String, Optional filtStr As String = "*.*") As Long
    '**********************
    'Code Courtesy of
    '  Paul Eugin
    '**********************
        Dim tmpPath As String, fCount As Long
        If Right$(fPath, 1) <> "\" Then fPath = fPath & "\"
        
        If Dir(fPath & filtStr) = "" Then
            getFileCount = 0
            Exit Function
        End If
        
        Do
            tmpPath = Dir
            fCount = fCount + 1
            If tmpPath = "" Then Exit Do
        Loop
        getFileCount = fCount
    End Function

    To use it, you need to use.

    file_count = getFileCount(fldrPath)


    Happy to help ! When you see answers and helpful posts, please click Vote As Helpful, Propose As Answer, and/or Mark As Answered


    Friday, February 21, 2014 10:44 AM
  • Hi It almost did the trick.

    I copied your code to a new model and replaced Application.FileSearch with file_count = getFileCount(fldrPath)

    Now I am getting Complie error: ByRef argument type mismatch..:(

    Friday, February 21, 2014 11:38 AM
  • Thought you might do that, what I mean was. Copy the code into a Standard Module.

    Then your code should be.

    Sub getData()
        Dim wbTemp As Workbook
        Dim wsTemp, wsDest, wsData, wsTime As Worksheet
       
        Set wsDataDest = ActiveWorkbook.Sheets("MI_Data")
        Set wsTimeDest = ActiveWorkbook.Sheets("MI_Timeout")
       
        wbPath = ActiveWorkbook.Path
        fldrPath = wbPath & "\Data Files"
       
        wsDataDest.Range("A2:AL65000").ClearContents
        wsTimeDest.Range("A2:F65000").ClearContents
    	
    	file_count = getFileCount(fldrPath)
       
    	For i = 1 To file_count
    		Application.ScreenUpdating = False
    		Set wbTemp = Application.Workbooks.Open(.FoundFiles(i))
    		wbTemp.Sheets("Data").Visible = xlSheetVisible
    		wbTemp.Sheets("Timeout").Visible = xlSheetVisible
    	   
    		Set wsData = wbTemp.Sheets("Data")
    		Set wsTime = wbTemp.Sheets("Timeout")
    	   
    		dRec = wsData.Cells(1, 1).End(xlDown).Row
    		tRec = wsTime.Cells(1, 1).End(xlDown).Row
    	   
    		dRwInd = wsDataDest.Cells(1, 1).End(xlDown).Row + 1
    		tRwInd = wsTimeDest.Cells(1, 1).End(xlDown).Row + 1
    	   
    	   
    		If dRec > 65000 Then
    			dRec = 2
    		End If
    	   
    		If tRec > 65000 Then
    			tRec = 2
    		End If
    	   
    		If dRwInd > 65000 Then
    			dRwInd = 2
    		End If
    	   
    		If tRwInd > 65000 Then
    			tRwInd = 2
    		End If
    	   
    '            If wsData.Cells(2, 4) = "" Then
    '                memName = Mid(.FoundFiles(i), x - 8, 2)
    '            Else
    			memName = wsData.Cells(2, 4)
    '            End If
    	   
    '            x = Len(.FoundFiles(i))
    '            wsDest.Cells(i + 1, 1) = memName
    '            wsDest.Cells(i + 1, 2) = Mid(.FoundFiles(i), 1, x)
    	   
    		rData = "A2:AI" & dRec
    		tData = "A2:F" & tRec
    	   
    		wsData.Range(rData).Copy
    		q = "A" & dRwInd
    		wsDataDest.Range(q).PasteSpecial
    		Application.CutCopyMode = False
    	   
    		wsTime.Range(tData).Copy
    		q = "B" & tRwInd
    		wsTimeDest.Range(q).PasteSpecial
    		Application.CutCopyMode = False
    		For j = tRwInd To (tRwInd + tRec) - 2
    			wsTimeDest.Cells(j, 1) = memName
    		Next j
    	   
    '           tempWS.Range("J6:J16").Copy
    '           wsDest.Range("B" & (i + 1)).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    	  
    		wbTemp.Sheets("Data").Visible = xlSheetVeryHidden
    		wbTemp.Sheets("Timeout").Visible = xlSheetVeryHidden
    		wbTemp.Close (False)
    		Application.ScreenUpdating = True
    	Next i
       
        MsgBox ("Data from " & file_count & " files successfully updated.")
           
        calReso
    End Sub


    Happy to help ! When you see answers and helpful posts, please click Vote As Helpful, Propose As Answer, and/or Mark As Answered

    Friday, February 21, 2014 11:42 AM
  • I did as you suggested but still same error message.

    i tried with declaring the fldrPath as string, but after that I am getting Invaldi or unqualified reference in (.FoundFiles(i))

    I really appriciate your effort on helping me.

    Friday, February 21, 2014 12:04 PM
  • Okay I did not see that you have to use the file later in the code. I thought you only wanted the File Count. That would change things. Okay. Lets do something about this. Scratch the code I gave before, replace it with the following.

    Function getFolderList(fPath As String, Optional filtStr As String = "*.*") As String
    '**********************
    'Code Courtesy of
    '  Paul Eugin
    '**********************
        Dim tmpPath As String, fList As String
        If Right$(fPath, 1) <> "\" Then fPath = fPath & "\"
        tmpPath = Dir(fPath & filtStr)
        If tmpPath = "" Then
            getFolderList = vbNullString
            Exit Function
        End If
        fList = fList & tmpPath & "|"
        Do
            tmpPath = Dir
            If tmpPath = "" Then Exit Do
            fList = fList & tmpPath & "|"
        Loop
        getFolderList = Left(fList, Len(fList) - 1)
    End Function

    Then, your modified code as,

    Sub getData()
        Dim wbTemp As Workbook, fileArr() As String
        Dim wsTemp, wsDest, wsData, wsTime As Worksheet
       
        Set wsDataDest = ActiveWorkbook.Sheets("MI_Data")
        Set wsTimeDest = ActiveWorkbook.Sheets("MI_Timeout")
       
        wbPath = ActiveWorkbook.Path
        fldrPath = wbPath & "\Data Files"
       
        wsDataDest.Range("A2:AL65000").ClearContents
        wsTimeDest.Range("A2:F65000").ClearContents
    	
    	fileArr = Split(getFolderList(fldrPath), "|")
    	file_count = UBound(fileArr)+1
       
    	For i = 1 To file_count
    		Application.ScreenUpdating = False
    		Set wbTemp = Application.Workbooks.Open(fileArr(i-1))
    		wbTemp.Sheets("Data").Visible = xlSheetVisible
    		wbTemp.Sheets("Timeout").Visible = xlSheetVisible
    	   
    		Set wsData = wbTemp.Sheets("Data")
    		Set wsTime = wbTemp.Sheets("Timeout")
    	   
    		dRec = wsData.Cells(1, 1).End(xlDown).Row
    		tRec = wsTime.Cells(1, 1).End(xlDown).Row
    	   
    		dRwInd = wsDataDest.Cells(1, 1).End(xlDown).Row + 1
    		tRwInd = wsTimeDest.Cells(1, 1).End(xlDown).Row + 1
    	   
    	   
    		If dRec > 65000 Then
    			dRec = 2
    		End If
    	   
    		If tRec > 65000 Then
    			tRec = 2
    		End If
    	   
    		If dRwInd > 65000 Then
    			dRwInd = 2
    		End If
    	   
    		If tRwInd > 65000 Then
    			tRwInd = 2
    		End If
    	   
    '            If wsData.Cells(2, 4) = "" Then
    '                memName = Mid(fileArr(i-1), x - 8, 2)
    '            Else
    			memName = wsData.Cells(2, 4)
    '            End If
    	   
    '            x = Len(fileArr(i-1))
    '            wsDest.Cells(i + 1, 1) = memName
    '            wsDest.Cells(i + 1, 2) = Mid(fileArr(i-1), 1, x)
    	   
    		rData = "A2:AI" & dRec
    		tData = "A2:F" & tRec
    	   
    		wsData.Range(rData).Copy
    		q = "A" & dRwInd
    		wsDataDest.Range(q).PasteSpecial
    		Application.CutCopyMode = False
    	   
    		wsTime.Range(tData).Copy
    		q = "B" & tRwInd
    		wsTimeDest.Range(q).PasteSpecial
    		Application.CutCopyMode = False
    		For j = tRwInd To (tRwInd + tRec) - 2
    			wsTimeDest.Cells(j, 1) = memName
    		Next j
    	   
    '           tempWS.Range("J6:J16").Copy
    '           wsDest.Range("B" & (i + 1)).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    	  
    		wbTemp.Sheets("Data").Visible = xlSheetVeryHidden
    		wbTemp.Sheets("Timeout").Visible = xlSheetVeryHidden
    		wbTemp.Close (False)
    		Application.ScreenUpdating = True
    	Next i
       
        MsgBox ("Data from " & file_count & " files successfully updated.")
           
        calReso
    End Sub


    Happy to help ! When you see answers and helpful posts, please click Vote As Helpful, Propose As Answer, and/or Mark As Answered




    Friday, February 21, 2014 12:33 PM