Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Get a Range from all wk in a folder...
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Get a Range from all wk in a folder...
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" wrote in message ... 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Get a Range from all wk in a folder...
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, Ctech Wrote: 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 *** ***Above code gives me an error: "Run time '438', Objet doesn't support this property or method. ******* ' 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 -- Ctech ------------------------------------------------------------------------ Ctech's Profile: http://www.excelforum.com/member.php...o&userid=27745 View this thread: http://www.excelforum.com/showthread...hreadid=486170 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Get a Range from all wk in a folder...
I don't see red, the NGs are all black text.
-- HTH RP (remove nothere from the email address if mailing direct) "Ctech" wrote in message ... 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, Ctech Wrote: 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 *** ***Above code gives me an error: "Run time '438', Objet doesn't support this property or method. ******* ' 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 -- Ctech ------------------------------------------------------------------------ Ctech's Profile: http://www.excelforum.com/member.php...o&userid=27745 View this thread: http://www.excelforum.com/showthread...hreadid=486170 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
How to decide folder-depth or How to select more folders/subfolders (folder-tree) ? | Excel Discussion (Misc queries) | |||
how can I specific a folder with wildcard criteria and excel will import all the correct files in that folder? | Excel Discussion (Misc queries) | |||
Macro to copy range from Excel files in folder | Excel Discussion (Misc queries) | |||
VBA to find Cell Range in Files in Folder, return value | Excel Programming | |||
Copy several range from all files in folder into several worksheets | Excel Programming |