+ Reply to Thread
Results 1 to 1 of 1

Extract Data to New Workbook

  1. #1
    Registered User
    Join Date
    01-14-2013
    Location
    United States
    MS-Off Ver
    MS Officel 2010
    Posts
    1

    Extract Data to New Workbook

    Hello,

    I've been searching online and am trying to find a solution to what I think should be easy to do. (Not so easy to me, as I'm not so proficient with VBA)

    I have a master sheet with information for multiple vendors and I would like to create a macro that would automatically would extract all rows of that particular vendor to a new workbook.

    I would want all formatting and column headers to read the same on all workbooks. specifically from A1-A7 through BA1-BA7, should be the header info on all sheets.

    Ideally, I would like to select each time with a dropdown menu if possible which vendor i'd like extract.
    If i NEED to extract all vendors at the same time, then I can deal with that.

    I found something similar in a different post and tried that code, but was having errors with it.

    Please help!

    Attached is what i have so far....anerror occurs at the rdata.copy destination line

    Sub ExtractToNewWorkBook()
    '
    ' Breakout_Schedule Macro
    ' Create New Sheets from Breakout Schedule
    '
    Dim ws As Worksheet
    Dim rData As Range
    Dim rCl As Range
    Dim sNm As String
    Set ws = Sheet1
    ' make sure this is correct

    'extract a list of unique names
    'first clear existing list
    With ws 'change the ranges to suit
    Set rData = .Range(.Cells(7, 1), .Cells(.Rows.Count, 14).End(xlUp))
    .Columns(.Columns.Count).Clear
    .Range(.Cells(8, 1), .Cells(.Rows.Count, 1).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(7, .Columns.Count), Unique:=True

    For Each rCl In .Range(.Cells(7, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
    sNm = rCl.Text
    'AutoFilter & copy to relevant sheet
    rData.AutoFilter Field:=1, Criteria1:=sNm
    Workbooks.Add
    ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & sNm & ".xls"
    rData.Copy Destination:=Workbooks(sNm).Sheets(1).Cells(1, 1)
    Workbooks(sNm).Close True
    Next rCl
    End With
    ws.Columns(Columns.Count).ClearContents 'remove temporary list
    rData.AutoFilter 'switch off AutoFilter
    End Sub
    '


    Attachment 206529

    thanks
    Sammy
    Attached Files Attached Files
    Last edited by screamersp; 01-14-2013 at 07:50 PM.

+ 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