Excel Macro To Build Master Order Sheets

[DCBUS]

Hello, I need to build a master order list from a master list. I have included two files. The original "Master List" and the output I need it to accomplish "Master List Complete". The original "Master List" will contain a unknown amount of rows when complied. I need the sheet names to be titled with the "Company". Each sheet will only contain the data from the "Master List" company. The final sheets need to be sorted by the "Cost" column sorting highest to lowest.

Thank you JR

Master List

[/URL][/IMG]

Master List Complete

[/URL][/IMG]

 

[mumps]

Try:

Sub CreateSheet()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Master List").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim company As Range
    Dim ws As Worksheet
    Dim rngUniques As Range
    Sheets("Master List").Range("D1:D" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("D1:D" & LastRow), Unique:=True
    Set rngUniques = Sheets("Master List").Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible)
    If Sheets("Master List").AutoFilterMode = True Then Sheets("Master List").AutoFilterMode = False
    For Each company In rngUniques
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(company.Value)
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = company.Value
            Sheets("Master List").Range("B1:G1").Copy Cells(1, 1)
        End If
    Next company
    For Each company In rngUniques
        Sheets("Master List").Range("D1:D" & LastRow).AutoFilter Field:=1, Criteria1:=company
        Sheets("Master List").Range("B2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy Sheets(company.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        If Sheets("Master List").AutoFilterMode = True Then Sheets("Master List").AutoFilterMode = False
    Next company
    Application.ScreenUpdating = True
 End Sub

 

[mumps]

Sorry. Forgot about the sorting. Please try this version:

Sub CreateSheet()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Master List").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim company As Range
    Dim ws As Worksheet
    Dim rngUniques As Range
    Sheets("Master List").Range("D1:D" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("D1:D" & LastRow), Unique:=True
    Set rngUniques = Sheets("Master List").Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible)
    If Sheets("Master List").AutoFilterMode = True Then Sheets("Master List").AutoFilterMode = False
    For Each company In rngUniques
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(company.Value)
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = company.Value
            Sheets("Master List").Range("B1:G1").Copy Cells(1, 1)
        End If
    Next company
    For Each company In rngUniques
        Sheets("Master List").Range("D1:D" & LastRow).AutoFilter Field:=1, Criteria1:=company
        Sheets("Master List").Range("B2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy Sheets(company.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        Range("D1").Select
        Sheets(company.Value).Sort.SortFields.Clear
        Sheets(company.Value).Sort.SortFields.Add Key:=Range("D2:D" & Sheets(company.Value).Range("D" & Sheets(company.Value).Rows.Count).End(xlUp).Row), _
            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With Sheets(company.Value).Sort
            .SetRange Sheets(company.Value).Range("A1:F" & Sheets(company.Value).Range("F" & Rows.Count).End(xlUp).Row)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        If Sheets("Master List").AutoFilterMode = True Then Sheets("Master List").AutoFilterMode = False
    Next company
    Application.ScreenUpdating = True
 End Sub

 

[DCBUS]

Hello Mumps,
Thank you for the reply. I tried the above and receiving error 400. It creates the correct sheets and only carries over BMW and erases all the reset. Would it also be possible to keep data in Master List as it also gets erased. Sorry to ask, but we also carry the header from Master list across the other sheets.

Thank you so much.
JR

 

[mumps]

When I tried the macro on some dummy data, it worked exactly as you requested. It is always easier to help and test possible solutions if we could work with your actual file. Perhaps you could upload a copy of your file to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[DCBUS]

Hello

Perfect. I did notice that I could not attach files here on the site. Here is the dropbox link to the two files, https://www.dropbox.com/sh/aztdr4w02nyop64/AACvKJMIdFIYieAhL-0GsaCHa?dl=0

Thank you

 

[Fluff]

Here's another option, if you're interested

Sub CopyData()

   Dim Cl As Range
   Dim OrigWs As Worksheet

Application.ScreenUpdating = False

   Set OrigWs = Sheets("Master List")
   If OrigWs.AutoFilterMode Then OrigWs.AutoFilterMode = False
   With CreateObject("scripting.dictionary")
      For Each Cl In OrigWs.Range("C2", OrigWs.Range("C" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            If Not ShtExists(Cl.Value) Then
               Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
            Else
               Sheets(Cl.Value).Cells.Clear
            End If
            OrigWs.Range("A1").AutoFilter 3, Cl.Value
            OrigWs.UsedRange.SpecialCells(xlVisible).Copy Sheets(Cl.Value).Range("A1")
            With Sheets(Cl.Value)
               .Sort.SortFields.Clear
               .Sort.SortFields.Add Key:=Range("D1"), SortOn:=xlSortOnValues, _
                  Order:=xlAscending, DataOption:=xlSortTextAsNumbers
               With .Sort
                  .SetRange Sheets(Cl.Value).UsedRange
                  .header = xlYes
                  .MatchCase = False
                  .Orientation = xlTopToBottom
                  .SortMethod = xlPinYin
                  .Apply
               End With
            End With
         End If
      Next Cl
   End With
   OrigWs.AutoFilterMode = False
      
End Sub

Public Function ShtExists(ShtName As String, Optional Wbk As Workbook) As Boolean
    If Wbk Is Nothing Then Set Wbk = ActiveWorkbook
    On Error Resume Next
    ShtExists = (LCase(Wbk.Sheets(ShtName).Name) = LCase(ShtName))
    On Error GoTo 0
End Function

 

[mumps]

Click here to download your file. When I ran the macro, I got all the sheets with the appropriate data.

 

[DCBUS]

Hello Mumps,

Thank you very much. The download version works perfect..

 

[DCBUS]

Thank you also to all replies.. JR