Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
variation to code needed
Hello Excel gurus. I found this code on this site and it does just what i need but for one thing. Instead of nominating workbooks i want to copy one worksheet from every workbook in folder. is it possible to do this???? Sub GetData() Dim WB As Workbook, WBmain As ThisWorkbook Dim Arr As Variant Dim i As Long Dim DestSh As Worksheet Dim SrcSh As Worksheet Dim Lrow As Long Dim myPath As String Dim RngToCopy As Range myPath = "C:\" If Right(myPath, 1) < "\" Then _ myPath = myPath & "\" Application.ScreenUpdating = False Arr = Array(".xls", ".xls", _ ".xls", ".xls") ' deletes "master" spreadsheet Application.DisplayAlerts = False Worksheets("master").UsedRange.Delete Application.DisplayAlerts = True Set WBmain = ThisWorkbook Set DestSh = WBmain.Worksheets(1) DestSh.Name = "master" Application.DisplayAlerts = False For i = LBound(Arr) To UBound(Arr) Set WB = Workbooks.Open(myPath & Arr(i)) Set SrcSh = WB.Sheets("data") With SrcSh.UsedRange Set RngToCopy = _ ..Offset(1).Resize(.Rows.Count - 1) If i = 0 Then .Rows(1).Copy DestSh.Cells(1) End With Lrow = LastRow(DestSh) RngToCopy.Copy DestSh.Cells(Lrow + 1, 1) WB.Close (False) Next DestSh.Cells(1).Select With Application ..DisplayAlerts = True ..ScreenUpdating = True End With 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 -- workingclassdog ------------------------------------------------------------------------ workingclassdog's Profile: http://www.excelforum.com/member.php...o&userid=25174 View this thread: http://www.excelforum.com/showthread...hreadid=386682 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
variation to code needed
Dim bk as Workbook, sh as Worksheet
Dim sName as String, sPath as String sPath = "C:\MyFiles\" sName = Dir(sPath & "*.xls") do while sName < "" With workbooks("Master.xls") set sh = .worksheets(.worksheets.count) end With if lcase(sName) < "master.xls" then set bk = Workbooks.Open(sPath & sName) bk.Worksheets(1).copy After:=sh End if sName = Dir() Loop -- Regards, Tom Ogilvy "workingclassdog" <workingclassdog.1s3dud_1121231125.7368@excelfor um-nospam.com wrote in message news:workingclassdog.1s3dud_1121231125.7368@excelf orum-nospam.com... Hello Excel gurus. I found this code on this site and it does just what i need but for one thing. Instead of nominating workbooks i want to copy one worksheet from every workbook in folder. is it possible to do this???? Sub GetData() Dim WB As Workbook, WBmain As ThisWorkbook Dim Arr As Variant Dim i As Long Dim DestSh As Worksheet Dim SrcSh As Worksheet Dim Lrow As Long Dim myPath As String Dim RngToCopy As Range myPath = "C:\" If Right(myPath, 1) < "\" Then _ myPath = myPath & "\" Application.ScreenUpdating = False Arr = Array(".xls", ".xls", _ ".xls", ".xls") ' deletes "master" spreadsheet Application.DisplayAlerts = False Worksheets("master").UsedRange.Delete Application.DisplayAlerts = True Set WBmain = ThisWorkbook Set DestSh = WBmain.Worksheets(1) DestSh.Name = "master" Application.DisplayAlerts = False For i = LBound(Arr) To UBound(Arr) Set WB = Workbooks.Open(myPath & Arr(i)) Set SrcSh = WB.Sheets("data") With SrcSh.UsedRange Set RngToCopy = _ Offset(1).Resize(.Rows.Count - 1) If i = 0 Then .Rows(1).Copy DestSh.Cells(1) End With Lrow = LastRow(DestSh) RngToCopy.Copy DestSh.Cells(Lrow + 1, 1) WB.Close (False) Next DestSh.Cells(1).Select With Application DisplayAlerts = True ScreenUpdating = True End With 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 -- workingclassdog ------------------------------------------------------------------------ workingclassdog's Profile: http://www.excelforum.com/member.php...o&userid=25174 View this thread: http://www.excelforum.com/showthread...hreadid=386682 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
variation to code needed
Thank you Tom. my VBA is no good so i cannot piece together. how can I enter: With SrcSh.UsedRange Set RngToCopy = _ Offset(1).Resize(.Rows.Count - 1) If i = 0 Then .Rows(1).Copy DestSh.Cells(1) End With Lrow = LastRow(DestSh) RngToCopy.Copy DestSh.Cells(Lrow + 1, 1) WB.Close (False) Next DestSh.Cells(1).Select With Application DisplayAlerts = True ScreenUpdating = True End With with the code that you offered. Thanks -- workingclassdog ------------------------------------------------------------------------ workingclassdog's Profile: http://www.excelforum.com/member.php...o&userid=25174 View this thread: http://www.excelforum.com/showthread...hreadid=386682 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Help needed with VBA code | Excel Discussion (Misc queries) | |||
Code Help Needed | Excel Programming | |||
Code Needed | Excel Programming | |||
Code Fix Needed | Excel Programming |