Macro which will filter and paste data to new worksheet

[pauldaddyadams]

Hi,

I need some help with a VBA code as I have no experience with writing a macro.

I have an unsorted data sheet which I need to extract information from and with each data extract I need it to create and save a new workbook.
1. On the tab GL – Column A I have a branch code consisting of 3 digits. What I need is a macro which creates a new workbook splitting out each branch.

e.g. in the example supplied I would like 5 new worksheets created showing data for branch 181 on one work sheet, 182 on another, 183 on another etc etc

2. For each new worksheet am I able to define the worksheet name – ideally I would like the branch name e.g. “181”

3. Is there any way in which I can define the workbook name and location to save to (if it doesn’t exist I would like it created).

I know this is a big ask – if there is a similar workbook that exists that I can copy the logic that you know of please point me in the right direction.

Any help is appreciated.

Paul

[Fotis1991]

Hello Paul

Give a try to this.

Sub PagesByDescription()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

    Set wSheetStart = ActiveSheet
    wSheetStart.AutoFilterMode = False
    'Set a range variable to the correct item column
    Set rRange = Range("A1", Range("A65536").End(xlUp))
    
        'Delete any sheet called "UniqueList"
        'Turn off run time errors & delete alert
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("UniqueList").Delete
        
        'Add a sheet called "UniqueList"
        Worksheets.Add().Name = "UniqueList"
        
           'Filter the Set range so only a unique list is created
            With Worksheets("UniqueList")
                rRange.AdvancedFilter xlFilterCopy, , _
                 Worksheets("UniqueList").Range("A1"), True
                 
                 'Set a range variable to the unique list, less the heading.
                 Set rRange = .Range("A2", .Range("A65536").End(xlUp))
            End With
            
            On Error Resume Next
            With wSheetStart
                For Each rCell In rRange
                  strText = rCell
                 .Range("A1").AutoFilter 1, strText
                    Worksheets(strText).Delete
                    'Add a sheet named as content of rCell
                    Worksheets.Add().Name = strText
                    'Copy the visible filtered range _
                    (default of Copy Method) and leave hidden rows
                    .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
                    ActiveSheet.Cells.Columns.AutoFit
                Next rCell
            End With
            
        With wSheetStart
            .AutoFilterMode = False
            .Activate
        End With
        
        On Error GoTo 0
        Application.DisplayAlerts = True
End Sub

[pauldaddyadams]

Hi

Thank you Fotis for replying so quickly.

That is what I am trying to achieve but rather than create a new worksheet I would like it to create a new workbook - can the code be tweeked to do this?

Ideally I would like the files to be saved directly to here:
P:\Test\Finance\manacc\MAN_ACC\Test2\2014\Mth0214\Transactional Reports\Hygiene

If that path doesnt already exist then I would like it created.

Could the file names be automatically defined e.g. "Transactional Report and the branch number (from column A) and the Month (I can define this in the macro each month)

[Fotis1991]

HaHoBe, in this thread provided a code for that! I don't like to copy that code and gives to you as mine!

[pauldaddyadams]

Hi,

Thanks for the link, I still need a bit of help please:

Currently the macro saves the file to the same desitnation as the orignal file:

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & strText & Format(Now, "YYMMDD_HHNNSS") & ".xlsm", FileFormat:=52

Is there any way I can change this to:

P:\Test\Finance\manacc\MAN_ACC\Test2\2014\Mth0214\Transactional Reports\Hygiene

And then rather than that file name e.g. "182140318_090259" could I have:

"Transactional Report and the branch number (from column A or the tab name) and the Month (I can define this in the macro each month)

I dont know how to amend the code to do this.

Regards

Paul

[Fotis1991]

...I dont know how to amend the code to do this.

Me too Paul!! Sorry!

[pauldaddyadams]

Hi,

I have found a code here:

https://sites.google.com/a/madrocket.../sheet1-to-wbs

But I would like to try and add elements of this code to yours Fotis.

Is there any way I can add these elements to your original code?:

'Path to save files into, remember the final \
    SvPath = "P:\Initial Washroom Solutions\Finance\manacc\MAN_ACC\RENTOKIL\2014\Mth0314\Transactional Reports\Hygiene\"

ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & " Transactional Report March14", xlNormal

I have uploaded a file which contains the 3 macros - I would like to merge the 3 really (your orignal code with the file path and file name elements).

Regards

Paul

[Fotis1991]

I just asked for help Paul. Lt's wait for a while.

[ragulduy]

Try:

Sub macro_1()
Dim count, ws1
Application.ScreenUpdating = False
Set ws1 = Activesheet
For count = 2 To ws1.Range("A" & Rows.count).End(xlUp).Row
    On Error GoTo not_found
        ws1.Rows(count).Copy Sheets("" & ws1.Range("A" & count)).Range("A" & Rows.count).End(xlUp).Offset(1, 0)
    On Error GoTo 0
Next count
ThisWorkbook.SaveAs "P:\Test\Finance\manacc\MAN_ACC\Test2\2014\Mth0214\Transactional Reports\Hygiene\" & ws1.name & ".xls"
Application.ScreenUpdating = True
Exit Sub
not_found:
Sheets.Add
ActiveSheet.Name = ws1.Range("A" & count)
Resume
End Sub

[Izandol]

Perhaps:

Const csSAVE_PATH                  As String = "P:\Initial Washroom Solutions\Finance\manacc\MAN_ACC\RENTOKIL\2014\Mth0314\Transactional Reports\Hygiene\"
' you may change this month
Const csMONTH_NAME                 As String = "March14"
Sub PagesByDescription()
    Dim rRange As Range, rCell     As Range
    Dim wSheet                     As Worksheet
    Dim wSheetStart                As Worksheet
    Dim wPaste                     As Worksheet
    Dim strText                    As String

    Set wSheetStart = ActiveSheet
    wSheetStart.AutoFilterMode = False
    'Set a range variable to the correct item column
    Set rRange = Range("A1", Range("A65536").End(xlUp))

    'Delete any sheet called "UniqueList"
    'Turn off run time errors & delete alert
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("UniqueList").Delete

    'Add a sheet called "UniqueList"
    Worksheets.Add().Name = "UniqueList"

    'Filter the Set range so only a unique list is created
    With Worksheets("UniqueList")
        rRange.AdvancedFilter xlFilterCopy, , _
                              Worksheets("UniqueList").Range("A1"), True

        'Set a range variable to the unique list, less the heading.
        Set rRange = .Range("A2", .Range("A65536").End(xlUp))
    End With

    On Error Resume Next
    With wSheetStart
        For Each rCell In rRange
            strText = rCell
            .Range("A1").AutoFilter 1, strText
            Worksheets(strText).Delete
            'Add new workbook with sheet named as content of rCell
            Set wPaste = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
            wPaste.Name = strText
            'Copy the visible filtered range _
             (default of Copy Method) and leave hidden rows
            .UsedRange.Copy Destination:=wPaste.Range("A1")
            wPaste.Cells.Columns.AutoFit
            With wPaste.Parent
                .SaveAs csSAVE_PATH & strText & " Transactional Report " & csMONTH_NAME, xlNormal
                .Close savechanges:=False
            End With
        Next rCell
    End With

    With wSheetStart
        .AutoFilterMode = False
        .Activate
    End With

    On Error GoTo 0
    Application.DisplayAlerts = True
End Sub

[pauldaddyadams]

Hi,

Thanks for the codes supplied here.

@ragulduy - I dont think this worked as it has not created new workbooks.

@Izandol - I think this may just be what I am after!! I will test it and report back (currently out of the office)