Solved: FileSearch VBA

[SDave]

Does anyone know how to modify the following?! I've only just discovered that the FileSearch function is not available in Excel 2007...

 
Sub ImportData()
    Dim fs As FileSearch
    Dim NewWB As Workbook
    Dim wks As Worksheet
    Dim msg As String, _
    orgWs As String
    msg = "Warning: Import External Data?" & vbNewLine & _
    vbNewLine & "Select OK to continue, or Cancel to exit"
    If MsgBox(msg, vbOKCancel) = vbCancel Then Exit Sub
    
    Application.ScreenUpdating = False
    Set fs = Application.FileSearch
    With fs
    .LookIn = "C:\Documents and Settings\DAVES\Desktop\TEST"
    .FileType = msoFileTypeExcelWorkbooks
    End With
    With fs
    If .Execute() > 0 Then
    For i = 1 To .FoundFiles.Count
    If Not .FoundFiles(i) Like "*Main.xls" Then
    Set NewWB = Workbooks.Open(.FoundFiles(i))
    NewWB.Sheets(1).Range(NewWB.Sheets(1).Range("A2"), NewWB.Sheets(1).Range("Q65536").End(xlUp)).Copy
    ThisWorkbook.Sheets(1).Range("C65536").End(xlUp).Offset(1).PasteSpecial xlValues
    Application.CutCopyMode = False
    NewWB.Close False
    End If
                 
    Next
    End If
    End With
End Sub

Any help would be much appreciated.

Thanks

[mdmackillop]

Give this a try
[vba]
Option Explicit
Sub ImportData()
Dim Pth As String
Dim MyFile As String
Dim msg As String

msg = "Warning: Import External Data?" & vbNewLine & _
vbNewLine & "Select OK to continue, or Cancel to exit"
If MsgBox(msg, vbOKCancel) = vbCancel Then Exit Sub
Application.ScreenUpdating = False
Pth = "C:\Documents and Settings\DAVES\Desktop\TEST\"
MyFile = Dir(Pth & "*.xls")
Do Until MyFile = ""
Call DoStuff(Pth, MyFile)
MyFile = Dir
Loop
End Sub

Sub DoStuff(Pth As String, MyFile As String)
Dim NewWB As Workbook
If Not MyFile Like "*Main.xls" Then
Set NewWB = Workbooks.Open(Pth & MyFile)
NewWB.Sheets(1).Range(NewWB.Sheets(1).Range("A2"), NewWB.Sheets(1).Range("Q65536").End(xlUp)).Copy
ThisWorkbook.Sheets(1).Range("C65536").End(xlUp).Offset(1).PasteSpecial xlValues
Application.CutCopyMode = False
NewWB.Close False
End If
End Sub
[/vba]

[SDave]

Hi mdmackillop,

Thanks for all your help thus far.

I've tried the code you've so kindly supplied but it doesn't seem to be working.

What I am trying to do is open all the files in a given folder, and copy the entire contents from a given sheet, in each workbook, say sheet1 for arguments sake, and paste the values into sheet "ABC" in my active workbook.

The code that I had originally supplied did do the trick - prior to Excel 2007 being installed on my machine.

[GTO]

Hi Dave,

I think just an errant keystroke. Try removing the exclamation point at the end of 'Pth'.

[mdmackillop]

Well spotted Mark!!!

[GTO]

Shucks Malcom, I could not seem to spot Set Rng() in the other to save my scalp... (and then I was still not following well... )

A great day to you, off to bed for this lad.

[SDave]

Thanks guys....

The code seems to be partly working.

A runtime error (ActiveX component cannot create object) is received when the code hits:

 
ThisWorkbook.Sheets("MasterInbound").Range("C65536").End(xlUp).Offset(1).PasteSpecial xlValues

Any thoughts?!

Even when I replace MasterInbound with a sheet number the same error seems to occur?!

[GTO]

I would think you would get a 'subscript out of range' error, if there was a problem on that line. Can you post the code, or a sample wb w/the code as you currently have it written?

[SDave]

Hi GTO,

What I am trying to do is open all the files in a given folder, and copy the entire contents from a given sheet, in each workbook, say "ABC" for arguments sake, and paste the values into sheet "DEF" in my active workbook.

the code is as follows:

 
Sub ImportInbound()
    Dim Pth As String
    Dim MyFile As String
    Dim msg As String
     
    msg = "Warning: Import External Data?" & vbNewLine & _
    vbNewLine & "Select OK to continue, or Cancel to exit"
    If MsgBox(msg, vbOKCancel) = vbCancel Then Exit Sub
    Application.ScreenUpdating = False
    Pth = "C:\Documents and Settings\DAVES\Desktop\TEST\"
    MyFile = Dir(Pth & "*.xls")
    Do Until MyFile = ""
        Call AppendInbound(Pth, MyFile)
        MyFile = Dir
    Loop
End Sub
Sub AppendInbound(Pth As String, MyFile As String)
    Dim NewWB As Workbook
    If Not MyFile Like "*Main.xls" Then
        Set NewWB = Workbooks.Open(Pth & MyFile)
        NewWB.Sheets(1).Range(NewWB.Sheets(1).Range("C11"), NewWB.Sheets(1).Range("S65536").End(xlUp)).Copy
        ThisWorkbook.Sheets(1).Range("C65536").End(xlUp).Offset(1).PasteSpecial xlValues
        Application.CutCopyMode = False
        NewWB.Close False
    End If
End Sub

It seems to open the files in say Folder1, copying the contents of "ABC", however it falls when it hits:

ThisWorkbook.Sheets(1).Range("C65536").End(xlUp).Offset(1).PasteSpecial xlValues

Regardless, of whether or not I specify the sheet name of sheet number, the same problem occurs.

[GTO]

I am afraid I cannot replicate the failure, sorry.

Mark

[SDave]

I've managed to solve the problem by tweaking the code:

 
Sub ImportInbound()
    Dim Pth As String
    Dim MyFile As String
    Dim msg As String
     
    msg = "Warning: Import External Data?" & vbNewLine & _
    vbNewLine & "Select OK to continue, or Cancel to exit"
    If MsgBox(msg, vbOKCancel) = vbCancel Then Exit Sub
    Application.ScreenUpdating = False
    Pth = "C:\Documents and Settings\DAVES\Desktop\TEST\"
    MyFile = Dir(Pth & "*.xls")
    Do Until MyFile = ""
        Call AppendInbound(Pth, MyFile)
        MyFile = Dir
    Loop
End Sub
Sub AppendInbound(Pth As String, MyFile As String)
    Dim NewWB As Workbook
    Dim wks As Worksheet
    If Not MyFile Like "*Main.xls" Then
        Set NewWB = Workbooks.Open(Pth & MyFile)
        NewWB.Sheets(1).Range(NewWB.Sheets(1).Range("C11"), NewWB.Sheets(1).Range("Q65536").End(xlUp)).Copy
        Windows("DI Master TEST.xlsm").Activate
        Sheets("MasterInbound").Range("C65536").End(xlUp).Offset(1).PasteSpecial xlValues
        Application.CutCopyMode = False
        NewWB.Close False
    End If
End Sub