Specific Data into individual worksheets using Macros/VGA RRS feed

  • Question

  • How do I take specific data and parse into multiple spreadsheets, with each worksheet names accordingly?

    I basically need to take below:

    Status Account Manager Advertiser Campaign Campus Type Campaign Type  Received Allocation   Billable CPL    Publisher  Allocated Amount  Allocation Type  Payable CPL  Notes

    and parse into individual spreadsheets by Publisher Name containing only following:

    Account Manager Publisher Campus Type Campaign Type  Allocated Amount  Allocation Type  Payable CPL  Notes

    Monday, July 25, 2016 6:44 PM


  • Select a cell in your "Publisher Name" column, and run this code - after adjusting the line

            shtT.Range("A:A,C:C,F:F").Delete  'Columns to remove

    to include the columns that you don't want in your new files.

    Sub ExportDataBaseToFiles()
        Dim endRow As Long
        Dim sh As Worksheet
        Dim shtT As Worksheet
        Dim rF As Range 'filter values
        Dim rD As Range 'range of data
        Dim c As Range
        Dim lCol As Long
        Set sh = ActiveSheet ' or use a specific sheet, like   Set sh = Sheets("DataBase")
        lCol = ActiveCell.Column  ' or use a specific column number, line     lCol = 3  'Column C
        'Retrieve the last used row number
        endRow = sh.Cells(sh.Rows.Count, lCol).End(xlUp).Row
        'First we find the unique values - assumes that headers are in row 1
        Set rD = sh.Range(sh.Cells(1, lCol), sh.Cells(endRow, lCol))
        rD.AdvancedFilter Action:=xlFilterCopy, copytorange:=sh.Cells(endRow + 4, lCol), Unique:=True
        Set rF = sh.Range(sh.Cells(endRow + 5, lCol), sh.Cells(sh.Rows.Count, lCol).End(xlUp))
        'Loop through the unique values
        For Each c In rF
            'Delete the worksheet if it exists already
            Application.DisplayAlerts = False
            On Error Resume Next
            On Error GoTo 0
            Application.DisplayAlerts = True
            'Make the new workhseet
            Set shtT = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            shtT.Name = c.Value
            'Find the values for the new worksheet
            With rD
                .AutoFilter field:=1, Criteria1:=c.Value
                .EntireRow.Copy shtT.Range("A1")
            End With
            shtT.Range("A:A,C:C,F:F").Delete  'Columns to remove
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx", 51
            ActiveWorkbook.Close False
        Next c
        'Clean up
        rF.Offset(-1).Resize(rF.Rows.Count + 1).Clear
    End Sub
    Monday, July 25, 2016 7:52 PM