Get a Range from all wk in a folder...

[Ctech]

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(mCostCenter)
' 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 |
+-------------------------------------------------------------------+

 

[Bob Phillips]

What doesn't work? There is too much code in there for us to work it out.

Here is some code to browse folders


Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long


Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long


Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'-----------------------------­------------------------------­--
Function GetFolder(Optional ByVal Name As String = _
"Select a folder.") As String
'-----------------------------­------------------------------­--
Dim bInfo As BROWSEINFO
Dim path As String
Dim oDialog As Long

bInfo.pidlRoot = 0& 'Root folder = Desktop

bInfo.lpszTitle = Name

bInfo.ulFlags = &H1 'Type of directory to Return
oDialog = SHBrowseForFolder(bInfo) 'display the dialog

'Parse the result
path = Space$(512)

GetFolder = ""
If SHGetPathFromIDList(ByVal oDialog, ByVal path) Then
GetFolder = Left(path, InStr(path, Chr$(0)) - 1)
End If

End Function


--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Ctech]

The first problem I get is this, see code in red below.
I do believe the rest of the errors I get is of similar type.

"Error: "Run time '438', Objet doesn't support this property or
method." (see more info in code below)

Thanks,

 

[Bob Phillips]

I don't see red, the NGs are all black text.

--

HTH

RP
(remove nothere from the email address if mailing direct)