Importing select Range from multiple workbooks

[Ron de Bruin]

hi deejayh

When you change my code you make a few mistakes

Test this one


Sub FSO_Example_new()
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\Contractor"
'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("Code").ComboBox2.Value

'Clear all cells on the first sheet
'basebook.Worksheets(1).Cells.Clear
basebook.Worksheets("import").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("import")) + 1

'With mybook.Sheets(1)
With mybook.Sheets(1) 'use the first sheet in every workbook
Set rng = Nothing

'Close AutoFilter first
.AutoFilterMode = False

'This example filter on column A , 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("import").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]

Hi Ron,

That really sorted it! Well done and Thanks.

I think I may of been getting mixed up with the sheets!?
Not sure if it meant this sheet, that sheet or the sheet in the
workbook to import!

Code:
--------------------
*et basebook = ThisWorkbook
str = Sheets("Code").ComboBox2.Value

'Clear all cells on the first sheet
'basebook.Worksheets(1).Cells.Clear
basebook.Worksheets("import").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("import")) + 1

'With mybook.Sheets(1)
With mybook.Sheets(1) 'use the first sheet in every workbook*
--------------------


I think that was the problem! Told you I was useless at this vba.

Now have to find out sorting the data then getting a chart out of it!

Onca again Ron, Many thanks,
Regards,
Dave

 

[Ron de Bruin]

You are welcome