Hi guys,

See the attached User Form for a visual feel of the macro.
The macro itself is pasted below.


Problems:

1. Would like a browse button, so the user can choose the folder
instead of pasting in the address manually.

2. I’m also having some problems with the code, which I haven't managed
to figure out.

What the macro does:

1. It opens all workbooks in a folder, and copies the specified range
to a blank spreadsheet. However it also have a built in function to
check if the decided spreadsheet is in the workbook. If it doesn't
exist it goes to the next wk.


All help and improvements is much appreciated:



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

Macro:

Dim sFileBase As String
Dim sFilename As String


Private Sub cmd_OK_Click()


Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Dim mRows As Long
Dim mSheet As String
Dim mCostCenter
Dim mRange

' Application.ScreenUpdating = False
' Application.DisplayAlerts = False
' Application.EnableEvents = False


Set wbCodeBook = ThisWorkbook

' Set active Cell
Range("A4").Select

mAddress = GetFromWorkbook.Txt_Address.Text
mRange = GetFromWorkbook.RefEdit_Range.Text
mSheet = GetFromWorkbook.Txt_Sheet.Text
mCostCenter = GetFromWorkbook.RefEdit_mCostCenter.Text



With Application.FileSearch
NewSearch
'Change path to suit
LookIn = mAddress & "\"
FileType = msoFileTypeExcelWorkbooks
'.Filename = "Book*.xls"

If .Execute 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all.
'Open Workbook x and Set a Workbook variable to it
Set wbResults =
Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)

'--------------- CODE HERE ------------------

' If the Sheet exist then
If SheetExists(mSheet, wbResults)
Then


' Activate Workbook
' Application.wbCodeBook.Activate

' Cost center in Column A
' If Not mCostCenter Is Nothing
Then
' ActiveCell =
Application.wbResults.Sheets(mSheet).Range(mCostCe nter)
' End If





' Copy Capital expenditure numbers

Application.wbResults.Sheets(mSheet).Range(mRange) .Select

' Count the number of rows in the
range
mRows =
Application.wbResults.Sheets(mSheet).Range(mRange) .Rows.Count

Selection.Copy


' Activate and paste the workbook
range to sheet
Application.wbCodeBook.Activate
ActiveCell.Offset(0,
1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
ActiveCell.Offset(0, -1).Select

' Set activeCell of next workbook
ActiveCell.Offset(mRows, 0).Select


' Delete Copied area for memory
Application.CutCopyMode = False

End If

'-------- END -- CODE HERE -- END ------------

' Do not save changes in opened workbooks
wbResults.Close SaveChanges:=False

Next lCount
End If
End With

On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

' Close the UserForm
Unload GetFromWorkbook
End Sub

'-----------------------------------------------------------------
Function SheetExists(Sh As String, _
Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error GoTo 0
End Function



Private Sub cmd_Cancel_Click()
Unload GetFromWorkbook
End Sub


+-------------------------------------------------------------------+
|Filename: Get-range-from-all-work.jpg |
|Download: http://www.excelforum.com/attachment.php?postid=4038 |
+-------------------------------------------------------------------+

--
Ctech
------------------------------------------------------------------------
Ctech's Profile: http://www.excelforum.com/member.php...o&userid=27745
View this thread: http://www.excelforum.com/showthread...hreadid=486170