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

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

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