PDA

View Full Version : Solved: FileSearch VBA



SDave
04-14-2010, 07:15 AM
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
04-14-2010, 07:57 AM
Give this a try

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

SDave
04-14-2010, 08:45 AM
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
04-14-2010, 10:32 AM
Hi Dave,

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

mdmackillop
04-14-2010, 10:48 AM
Well spotted Mark!!!

GTO
04-14-2010, 11:03 AM
Shucks Malcom, I could not seem to spot Set Rng() in the other to save my scalp...:stars: (and then I was still not following well...:bow: )

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

SDave
04-15-2010, 01:18 AM
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
04-15-2010, 02:02 AM
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
04-15-2010, 02:12 AM
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
04-15-2010, 02:46 AM
I am afraid I cannot replicate the failure, sorry.

Mark

SDave
06-14-2010, 05:32 AM
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