+ Reply to Thread
Results 1 to 1 of 1

Create and Label Multiple Workbooks Using Data From Master Workbook

  1. #1
    Registered User
    Join Date
    04-23-2013
    Location
    USA
    MS-Off Ver
    Excel 2007
    Posts
    1

    Create and Label Multiple Workbooks Using Data From Master Workbook

    Hello,

    I am new at using VBA and need some help with a macro. I have a workbook that I need to split out and create a new workbook for each plan number. The new workbook needs to be labeled by the plan number in Column B and the data (A1:Y5) for that group number needs to populate the new workbook. I need this to repeat for each plan number in the workbook. There isn't a set number of rows to the next plan number. This always varies and I don't know what code to use for it to pick up the next plan number and the data that follows.

    I found some code that got me started. It will create a new workbook for each plan number, but it doesn't populate the new workbook with all the data for that plan number. Please see the attached example workbook. I greatly appreciate any help with modifing this code.

    Thanks,
    Chris

    Sub Conexis()

    Dim thisWB As String

    Dim newWB As String

    thisWB = ActiveWorkbook.Name

    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0

    Sheets.Add
    ActiveSheet.Name = "tempsheet"

    Sheets("Sheet1").Select

    If ActiveSheet.AutoFilterMode Then
    Cells.Select

    On Error Resume Next

    ActiveSheet.ShowAllData

    On Error GoTo 0

    End If

    Columns("B:B").Select
    Selection.Copy

    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

    If (Cells(1, 1) = "") Then
    lastrow = Cells(1, 1).End(xlDown).Row

    If lastrow <> Rows.Count Then
    Range("A1:A" & lastrow - 1).Select
    Selection.Delete Shift:=xlUp
    End If

    End If

    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("B1"), Unique:=True

    Columns("A:A").Delete

    Cells.Select
    Selection.Sort _
    Key1:=Range("A2"), Order1:=xlAscending, _
    Header:=xlYes, OrderCustom:=1, _
    MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal

    lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row

    For suppno = 2 To lMaxSupp

    Windows(thisWB).Activate

    supName = Sheets("tempsheet").Range("A" & suppno)

    If supName <> "" Then

    Workbooks.Add
    ActiveWorkbook.SaveAs supName
    newWB = ActiveWorkbook.Name

    Windows(thisWB).Activate

    Sheets("Sheet1").Select
    Cells.Select

    If ActiveSheet.AutoFilterMode = False Then
    Selection.AutoFilter
    End If

    Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
    Operator:=xlAnd, Criteria2:="<>"

    lastrow = Cells(Rows.Count, 2).End(xlUp).Row

    Rows("1:" & lastrow).Copy

    Windows(newWB).Activate
    ActiveSheet.Paste

    ActiveWorkbook.Save
    ActiveWorkbook.Close

    End If

    Next

    Sheets("tempsheet").Delete

    Sheets("Sheet1").Select
    If ActiveSheet.AutoFilterMode Then
    Cells.Select
    ActiveSheet.ShowAllData
    End If

    End Sub
    Attached Files Attached Files
    Last edited by ChrisAnthony; 04-23-2013 at 01: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