Solved: Call for Data from folder

[Emoncada]

I have a spreadsheet that only has headers in Row 1. In the header i have a txtbox. I have some code to call up a calendar. I would like to know if when the calendar is called and the date is entered in the txtbox. I will have a button next to the txtbox labeled "GO". I would like for that button to grab the date and break it down so it know where to locate the files. So if the date is 12/22/2007. The script to pull this
[vba]
"C:\Packing Slip\" &
Dec 2007 ("mm yyyy" & "\" &) 'This is the part it needs to grab from the date.
Dec 22 ("mm dd" & "\" &) 'This is also a part it needs to grab from the date.
[/vba]
Then grab all .xls files in that folder. Then grab the data from column A2:O from all spreadsheets. How can i make this happen for all spreadsheet in that folder?

[XLGibbs]

There are numerous methods depending on what you want to do when you "grab" them.

Do a search of the excel forum for "Application.FileSearch" and "open all files in folder" to see samples you can work from.

[Bob Phillips]

Don't use FileSearch, it is dropped in Excel 2007. Use Dir or FSO.

[Emoncada]

I searches several threads i can't seem to find anything im looking for. If anyone finds one please let me know.

Thanks

[Emoncada]

I found this code

[vba]Option Explicit
Sub Example()
Const strRootFolder_c As String = "C:\Depot Outgoing\"
Const lngLwrBnd_c As Long = 1
Const lngOffset_c As Long = 1
Dim fs As Office.FileSearch
Dim lngFileIndex As Long
Dim wbNew As Excel.Workbook
Dim wsTarget As Excel.Worksheet
Dim wbCrnt As Excel.Workbook
Dim wsOne As Excel.Worksheet
Set fs = Excel.Application.FileSearch
fs.NewSearch
fs.FileType = msoFileTypeExcelWorkbooks
fs.LookIn = strRootFolder_c & [f1] & "\" & [g1] & "\" & [h1]
fs.Execute
If fs.FoundFiles.Count < lngLwrBnd_c Then
VBA.MsgBox _
"Cannot find any workbooks in the specified root folder. Please check to make sure you have excel workbooks in the location specified. Operation aborted.", _
vbExclamation Or vbSystemModal, "No Workbooks Found"
Exit Sub
End If
Set wbNew = Excel.Workbooks.Add
Set wsTarget = wbNew.Worksheets(lngLwrBnd_c)
For lngFileIndex = lngLwrBnd_c To fs.FoundFiles.Count
Set wbCrnt = Excel.Workbooks.Open(fs.FoundFiles(lngFileIndex), False, _
False, Password:="foo")
Set wsOne = wbCrnt.Worksheets(lngLwrBnd_c)
wsOne.UsedRange.Copy wsTarget.Cells(wsTarget.UsedRange.Rows.Count + _
lngOffset_c, lngLwrBnd_c)
wbCrnt.Close False
Next
VBA.MsgBox "All worksheets have been merged.", vbInformation Or _
vbSystemModal, "Operation Complete"
End Sub[/vba]

Im trying to see if i can make it work for me. But it's not working.
I get the

"Cannot find any workbooks in the specified root folder. Please check to make sure you have excel workbooks in the location specified. Operation aborted." Can someone see what's wrong.

[Emoncada]

Bump!

[Emoncada]

I have this code now but it's not doing anything for me. Can someone see what's missing.

[vba]Sub CopyToMaster()
Dim wbMaster As Workbook
Dim wb As Workbook
Dim strPath As String
Dim strFile As String
Dim lngRow As Long
Dim i As String

On Error GoTo ErrHandler
Application.ScreenUpdating = False

' this assumes that the master workbook is active
Set wbMaster = ActiveWorkbook

StartDate = Format(Worksheets("Test").Range("c2").Value, "yyyy")
MiddleDate = Format(Worksheets("Test").Range("c2").Value, "mmm yyyy")
EndDate = Format(Worksheets("Test").Range("c2").Value, "mmm dd")


strPath = "C:\Depot Outgoing\" & StartDate & "\" & MiddleDate & "\" & EndDate
strFile = Dir(strPath & "*.xls", vbNormal)

' loop through all files in the folder
Do Until strFile = ""
' if the master is in the same folder, make sure it's excluded
If strFile <> "Master Pim.xls" Then
' find last row in column B
lngRow = wbMaster.Test.Cells(Cells.Rows.Count, 2).End(xlUp).Row + 1

Workbooks.Open strPath & strFile

Set wb = ActiveWorkbook
' copy the data directly to the destination
wb.Sheets(1).Range("a5:O3000").Copy wbMaster.Sheets(1).Range("B" & lngRow)

wbMaster.Activate
Test.Range("B" & lngRow + 2).PasteSpecial xlPasteValues

Application.CutCopyMode = False
wb.Close False
End If
' find next file
strFile = Dir()
Loop

ExitHere:
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Number & ": " & Err.Description
Resume ExitHere
End Sub[/vba]

[Emoncada]

This is the spreadsheet with a Test Tab.

[rbrhodes]

Hi Emoncada,

Try this. See the comments in the code.

[VBA]
Sub CopyToMasterDR()

Dim lngRow As Long
Dim wb As Workbook
Dim FileCount As Long 'Added for no files found check
Dim strPath As String
Dim strFile As String
Dim wbMaster As Workbook
On Error GoTo ErrHandler
Application.ScreenUpdating = False

' this assumes that the master workbook is active
Set wbMaster = ActiveWorkbook

'Make sure dir exists! Note hard coded Drive/Dir name and
' also VBA generated spaces in Month/Year and Month/Day eg:
' "C:\Depot Outgoing\2007\Dec 2007\Dec 27\"
StartDate = Format(Worksheets("Test").Range("c2").Value, "yyyy")
MiddleDate = Format(Worksheets("Test").Range("c2").Value, "mmm yyyy")
EndDate = Format(Worksheets("Test").Range("c2").Value, "mmm dd")

'Missing path separator in original code, Corrected with \
strPath = "C:\Depot Outgoing\" & StartDate & "\" & MiddleDate & "\" & EndDate & "\"
strFile = Dir(strPath & "*.xls", vbNormal)

' loop through all files in the folder
Do Until strFile = ""
' if the master is in the same folder, make sure it's excluded
'Added UCASE to do proper check
If UCase(strFile) <> "MASTER PIM.XLS" Then

'At least one file found. Mark as such.
FileCount = 1

' find last row in column B
lngRow = wbMaster.Sheets("Test").Cells(Cells.Rows.Count, 2).End(xlUp).Row + 1

Workbooks.Open strPath & strFile

Set wb = ActiveWorkbook
' copy the data diorectly to master sheet (sheet 1)
wb.Sheets(1).Range("a5:O3000").Copy wbMaster.Sheets(1).Range("B" & lngRow)

wbMaster.Activate
'Recopy for PasteSpecial operation (kludge)
wb.Sheets(1).Range("a5:O3000").Copy

'Full command
ActiveWorkbook.Sheets("Test").Range("B" & lngRow + 2).PasteSpecial _
Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Application.CutCopyMode = False
wb.Close False
End If
' find next file
strFile = Dir()
Loop

ExitHere:
'Check for no files found, inform user
If FileCount < 1 Then
MsgBox ("No files found in Directory " & strPath)
End If
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Number & ": " & Err.Description
Application.ScreenUpdating = True
End Sub

[/VBA]

[Emoncada]

That looks great rb Thanks So Much!

Do you know if there is a way instead of saying a range.
To have it detect the last row of data and then copy that range?

[rbrhodes]

Hi,

Detect the last row in which Column? In which sheet? Which Workbook?

You currently have:

wb.Sheets(1).Range("a5:O3000").Copy

Is this the range you're speaking of?

If so, is there a column in this range that will _always_ have data and therefore always contain the last row e.g. Col A will always have something in it even if Col B to O are blank.

If so you can determine the last row using Column A (or any other Column of your choice.)

See the comments in the revised code:

[VBA]
Sub CopyToMasterDR()
Dim lngRow As Long
Dim wb As Workbook
Dim lastrow As Long '**Added for 'Range'
Dim FileCount As Long 'Added for no files found check
Dim strPath As String
Dim strFile As String
Dim wbMaster As Workbook
On Error GoTo ErrHandler
Application.ScreenUpdating = False

' this assumes that the master workbook is active
Set wbMaster = ActiveWorkbook
'Make sure dir exists! Note hard coded Drive/Dir name and
' also VBA generated spaces in Month/Year and Month/Day eg:
' "C:\Depot Outgoing\2007\Dec 2007\Dec 27\"
StartDate = Format(Worksheets("Test").Range("c2").Value, "yyyy")
MiddleDate = Format(Worksheets("Test").Range("c2").Value, "mmm yyyy")
EndDate = Format(Worksheets("Test").Range("c2").Value, "mmm dd")
'Missing path separator in original code, Corrected with \
strPath = "C:\Depot Outgoing\" & StartDate & "\" & MiddleDate & "\" & EndDate & "\"
strFile = Dir(strPath & "*.xls", vbNormal)
' loop through all files in the folder
Do Until strFile = ""
' if the master is in the same folder, make sure it's excluded
'Added UCASE to do proper check
If UCase(strFile) <> "MASTER PIM.XLS" Then
'At least one file found. Mark as such.
FileCount = 1
' find last row in column B in MASTER SHEET
lngRow = wbMaster.Sheets("Test").Cells(Cells.Rows.Count, 2).End(xlUp).Row + 1
Workbooks.Open strPath & strFile
Set wb = ActiveWorkbook
'** Find last row of data in Wb to copy FROM
lastrow = Range("A65536").End(xlUp).Row
' copy the data directly to master sheet (sheet 1)
'USING LASTROW
wb.Sheets(1).Range("a5:O" & lastrow).Copy wbMaster.Sheets(1).Range("B" & lngRow)
wbMaster.Activate
'Recopy for PasteSpecial operation (kludge)
'USING LASTROW
wb.Sheets(1).Range("a5:O" & lastrow).Copy
'Full command
ActiveWorkbook.Sheets("Test").Range("B" & lngRow).PasteSpecial _
Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
wb.Close False
End If
' find next file
strFile = Dir()
Loop
ExitHere:
'Check for no files found, inform user
If FileCount < 1 Then
MsgBox ("No files found in Directory " & strPath)
End If
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
Application.ScreenUpdating = True
End Sub
[/VBA]