+ Reply to Thread
Results 1 to 3 of 3

variation to code needed

  1. #1
    Registered User
    Join Date
    07-13-2005
    Posts
    2

    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

  2. #2
    Tom Ogilvy
    Guest

    Re: 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"
    <[email protected]> wrote in
    message news:[email protected]...
    >
    > 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. #3
    Registered User
    Join Date
    07-13-2005
    Posts
    2
    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

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1