Importing select Range from multiple workbooks

[deejayh]

Hi,

Is there any way to import certain data from multiple workbooks held i
a directory and sub directories below that.

I recieve 8 workbooks every month from 8 suppliers. They are saved in
subdirectory under c:\audit. For example: supplier1 subdirectory-wit
all the audits for every month (depending on the time of year!)
January.xls, February.xls.....

The audit for each month contains:
Region, District, Store No, Score1, Score2, Score3, Score4
4, 101, 2345, 2, 4, 3, 1,
5, 206, 7298, 3, 1, 1, 4,

I want to be able to import all sites from District 101.
In other words, I click a button, (vba?) then goes into al
subdirectories of c:\audit, looks at each workbook, selects all row
that = district 101.

Can this be done?
Hopefully I have explained correctly.
Regards,
Dav

 

[Mike Fogleman]

There should be some code on Ron de Bruin's site that will get you started:

http://www.rondebruin.nl/tips.htm

You should probably pull in all the data to your workbook and then filter
for District 101 and discard the rest.

Mike F

 

[deejayh]

Thanks for the reply Mike,

Funny thing is I am using code from http://www.rondebruin.nl

But I don't know how to expand this to check a column - "District" an
to bring in data from the corresponding row?

Any help appreciated

Regards,
Dav

 

[deejayh]

Thanks for the reply Mike,

Funny thing is I am using code from http://www.rondebruin.nl

But I don't know how to expand this to check a column - "District" and
to bring in data from the corresponding row?

I would also like for the user to select from a dropdown a "District"
and then for the code to run. If that could be possible?

Any help appreciated

Regards,
Dave

 

[Ron de Bruin]

Hi deejayh

I try to update the site with a filter example next week

 

[deejayh]

Hi Ron,

Many thanks for your help. I am visiting your site every day

Hopefully you will add this soon, as I have to have it completed by
next Tuesday -no pressure

Thanks again,

All the best,
Dave

 

[Ron de Bruin]

Hi deejayh

Ok, here is a tester for you that filter the range A1:A100 in the first sheet in each workbook (in C:\Data) for ron
and copy the complete row in the first sheet of the workbook with the code.

Try to work more on it this evening and update the site
Maybe this help you today

Sub Example1_Filter_Workbooks()
'Note: This example use the function LastRow
Dim basebook As Workbook
Dim mybook As Workbook
Dim rng As Range
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Data"
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook

Do While FNames <> ""


rnum = LastRow(basebook.Worksheets(1)) + 1
Set mybook = Workbooks.Open(FNames)

With mybook.Sheets(1)

'Close AutoFilter first
.AutoFilterMode = False

'This example filter on column A for ron, note A1 ia the Header cell
.Range("A1:A100").AutoFilter Field:=1, Criteria1:="ron"

With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Copy basebook.Worksheets(1).Cells(rnum, "A")
End If
End With
.AutoFilterMode = False
End With


mybook.Close False

FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

 

[Ron de Bruin]

Oops
This is not working correct
Send a good macro one this evening


--
Regards Ron de Bruin
http://www.rondebruin.nl

Hi deejayh

Ok, here is a tester for you that filter the range A1:A100 in the first sheet in each workbook (in C:\Data) for ron
and copy the complete row in the first sheet of the workbook with the code.

Try to work more on it this evening and update the site
Maybe this help you today

Sub Example1_Filter_Workbooks()
'Note: This example use the function LastRow
Dim basebook As Workbook
Dim mybook As Workbook
Dim rng As Range
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Data"
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook

Do While FNames <> ""


rnum = LastRow(basebook.Worksheets(1)) + 1
Set mybook = Workbooks.Open(FNames)

With mybook.Sheets(1)

'Close AutoFilter first
.AutoFilterMode = False

'This example filter on column A for ron, note A1 ia the Header cell
.Range("A1:A100").AutoFilter Field:=1, Criteria1:="ron"

With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Copy basebook.Worksheets(1).Cells(rnum, "A")
End If
End With
.AutoFilterMode = False
End With


mybook.Close False

FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

 

[Ron de Bruin]

This one is working

'This basic example filter the range A1:A100 on the first sheet in each workbook (in C:\Data) for ron
'and copy the complete row(s) to the first sheet of the workbook with this code.
'Note: This example use the function LastRow


Sub Example1_Filter_Workbooks()
'Note: This example use the function LastRow
Dim basebook As Workbook
Dim mybook As Workbook
Dim rng As Range
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Data" '<<< Change
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook

Do While FNames <> ""

'Find the last row on the first sheet(used to copy the data below the data that exist)
rnum = LastRow(basebook.Worksheets(1)) + 1

'Open the workbook
Set mybook = Workbooks.Open(FNames)

With mybook.Sheets(1)
Set rng = Nothing

'Close AutoFilter first
.AutoFilterMode = False

'This example filter on column A for ron, Note: A1 is the Header cell
'Change the range and criteria to your Range/Criteria
.Range("A1:A100").AutoFilter Field:=1, Criteria1:="ron"

With .AutoFilter.Range

' Set a range without the Header cell
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

'If there isdata copy the rows
If Not rng Is Nothing Then
rng.EntireRow.Copy basebook.Worksheets(1).Cells(rnum, "A")
End If

End With

'Close AutoFilter
.AutoFilterMode = False
End With

'Close the workbook
mybook.Close False

'Go to the Next workbook in the folder
FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


--
Regards Ron de Bruin
http://www.rondebruin.nl

Oops
This is not working correct
Send a good macro one this evening

 

[deejayh]

Thanks very much for that Ron - I appreciate it.

Couple of other questions:
1) How do I add a Combo Box and set the value within your code?
for example on the combo you could select "201" then (with your code
goes into all the directories and selects all the data in a range o
B8:B400

2) How do I get it to search in all subdirectories below c:\Data?

Also how can I set the data to go into a specific sheet?

Thanks again Ron,
Regards,
Dav

 

[Ron de Bruin]

Do you want to use a combobox or a validation dropdown?
Do you know the values that must be in the combo?

2) you can add the filter code in the code on this page
http://www.rondebruin.nl/fso.htm

3) I show you in my reply when I have read your reply

 

[deejayh]

Hi Ron,

Do you want to use a combobox or a validation dropdown?
Whichever, see below
Do you know the values that must be in the combo?

I have used previously a combobox, with a list in the same workbook but
on another sheet, with 2 columns: Region, District
ie.. West, 101
The last figure"District" being the value required.

Also how can I set the data to go into a specific sheet?

Many thanks Ron,
Dave

 

[Ron de Bruin]

Ok you have the combobox already so you can read the selected value

See this example that copy in a sheet named "Sheet2"
(you see it two times in the code)

And use a combobox on Sheet3 named ComboBox1
Sheets("Sheet3").ComboBox1.Value

Test this and you can add the code in the filesystemobject example on my site
http://www.rondebruin.nl/fso.htm


Sub Example13()
'Note: This example use the function LastRow
Dim basebook As Workbook
Dim mybook As Workbook
Dim rng As Range
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim str As String

SaveDriveDir = CurDir
MyPath = "C:\Data" '<<< Change
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
str = Sheets("Sheet3").ComboBox1.Value

Do While FNames <> ""

'Find the last row on the first sheet (used to copy the data below the data that exist)
rnum = LastRow(basebook.Worksheets("Sheet2")) + 1

'Open the workbook
Set mybook = Workbooks.Open(FNames)

With mybook.Sheets(1)
Set rng = Nothing

'Close AutoFilter first
.AutoFilterMode = False

'This example filter on column A for ron, Note: A1 is the Header cell
'Change the range and criteria to your Range/Criteria
.Range("A1:A100").AutoFilter Field:=1, Criteria1:=str

With .AutoFilter.Range

' Set a range without the Header cell
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

'If there is data copy the rows
If Not rng Is Nothing Then
rng.EntireRow.Copy basebook.Worksheets("Sheet2").Cells(rnum, "A")
End If

End With

'Close AutoFilter
.AutoFilterMode = False

End With

'Close the workbook
mybook.Close False

FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

 

[deejayh]

Hi Ron,

Many thanks for that - but being a complete novice I cannot see how to
add the http://www.rondebruin.nl/fso.htm - FileSystemObject

I have now put the data as follows:
c:\audit
example:
c:\audit\contractors\supplier1\ddd.xls
c:\audit\contractors\supplier2\sss.xls

The range to check is B8:B400
The column is I


Code:
--------------------
Sub Example1_Filter_Workbooks()
'Note: This example use the function LastRow
Dim basebook As Workbook
Dim mybook As Workbook
Dim rng As Range
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim str As String

SaveDriveDir = CurDir
MyPath = "C:\audit\Contractor\" '<<< Change
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
str = Sheets("Code").ComboBox2.Value
Do While FNames <> ""

'Find the last row on the first sheet(used to copy the data below the data that exist)
rnum = LastRow(basebook.Worksheets(1)) + 1

'Open the workbook
Set mybook = Workbooks.Open(FNames)

With mybook.Sheets(1)
Set rng = Nothing

'Close AutoFilter first
.AutoFilterMode = False

'This example filter on column A for ron, Note: A1 is the Header cell
'Change the range and criteria to your Range/Criteria
.Range("B8:B400").AutoFilter Field:=1, Criteria1:=str '<<< Change

With .AutoFilter.Range

' Set a range without the Header cell
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

'If there isdata copy the rows
If Not rng Is Nothing Then
rng.EntireRow.Copy basebook.Worksheets(1).Cells(rnum, "A")
End If

End With

'Close AutoFilter
.AutoFilterMode = False
End With

'Close the workbook
mybook.Close False

'Go to the Next workbook in the folder
FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

--------------------

Oh the other thing, in the audits (the data to be imported) I have some
comments and pictures which are being seen when you import - anyway to
turn these off also?

Many many thanks again,
Cheers,
Dave

 

[deejayh]

Does anyone know how to get the data from all subdirectories of
c:\audit\contractors\ ???

 

[Ron de Bruin]

Does anyone know how to get the data from all subdirectories of

c:\audit\contractors\ ???

I have to sleep and work <vbg>

Try this one

Sub FSO_Example_1()
Dim SubFolders As Boolean
Dim Fsbj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object
Dim RootPath As String, FileExt As String
Dim MyFiles() As String, Fnum As Long
Dim rng As Range, str As String
Dim rnum As Long
Dim basebook As Workbook, mybook As Workbook

'Loop through all files in the Root folder
RootPath = "C:\audit"
'Loop through the subfolders True or False
SubFolders = True
'Loop through files with this extension
FileExt = ".xls"

'Add a slash at the end if the user forget it
If Right(RootPath, 1) <> "\" Then
RootPath = RootPath & "\"
End If

Set Fsbj = CreateObject("Scripting.FileSystemObject")
If Not Fsbj.FolderExists(RootPath) Then
MsgBox RootPath & " Not exist"
Exit Sub
End If

Set RootFolder = Fsbj.GetFolder(RootPath)

'Fill the array(myFiles)with the list of Excel files in the folder(s)
Fnum = 0
'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(Right(file.Name, 4)) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = RootPath & file.Name
End If
Next file

'Loop through the files in the Sub Folders if SubFolders = True
If SubFolders Then
For Each SubFolderInRoot In RootFolder.SubFolders
For Each file In SubFolderInRoot.Files
If LCase(Right(file.Name, 4)) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = SubFolderInRoot & "\" & file.Name
End If
Next file
Next SubFolderInRoot
End If


' Now we can open the files in the array MyFiles to do what we want
'******************************************************************

On Error GoTo CleanUp
Application.ScreenUpdating = False

Set basebook = ThisWorkbook
str = Sheets("Sheet3").ComboBox1.Value

'Clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyFiles(Fnum))
rnum = LastRow(basebook.Worksheets("Sheet2")) + 1

With mybook.Sheets(1)
Set rng = Nothing

'Close AutoFilter first
.AutoFilterMode = False

'This example filter on column A for ron, Note: A1 is the Header cell
'Change the range and criteria to your Range/Criteria
.Range("B8:B400").AutoFilter Field:=1, Criteria1:=str

With .AutoFilter.Range

' Set a range without the Header cell
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0


'If there is data copy the rows
If Not rng Is Nothing Then
rng.EntireRow.Copy basebook.Worksheets("Sheet2").Cells(rnum, "A")
End If

End With

'Close AutoFilter
.AutoFilterMode = False

End With

mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

 

[deejayh]

You are the man!

Thanks I will try that when I am back at work on Thursday.

Cheers Ron.

 

[deejayh]

Hi Ron,

Sorry to say that this one is not working.
It will only open the first file in the first folder. Then stops with
the first .xls file open.

Thanks,
Dave

 

[Ron de Bruin]

Working OK for me
Send me one of the files then I look at it

 

[deejayh]

Hi Ron,

Sent to your email address on your website.

Thanks again,

Best regards,
Dave