Results 1 to 7 of 7
  1. #1
    New Lounger
    Join Date
    Sep 2013
    Posts
    17
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Macro to split out spreadsheet-Reopened

    Hi Maud,

    Topic Reference : Macro to split out spreadsheet : http://windowssecrets.com/forums/sho...ut-spreadsheet

    I am impressed and interested in adopting this codes for my project, but i need 2 more features added to it.

    1. After spliting the spreadsheet to be saved as pdf.
    2. The pdf's to be saved in folders pre-defined path for each of them individually.
    D:\Rentreceipt\(Todays-date)\HouseNo\001\Tom\Tom.pdf
    D:\Rentreceipt\(Todays-date)\HouseNo\002\Bill\Bill.pdf
    D:\Rentreceipt\(Todays-date)\HouseNo\003\Fred\Fred.pdf
    D:\Rentreceipt\(Todays-date)\HouseNo\004\George\George.pdf

    Thanks in advance.
    Code:
    Public Sub DestinationFilter()
    Application.ScreenUpdating = False
    'DECLARE AND SET VARIABLES
    Dim rng As Range
    Dim FilterArray()
    Dim Distributor As Range
    Set CurrentWb = ActiveWorkbook
    LastRow1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Range(Cells(2, 1), Cells(LastRow1, 1))
    Set rng2 = Range("A1:E" & LastRow1)
    '-----------------------------------------------
    'GET LIST OF FILTER CRITERIA
    rng.Copy
    [f2].Select
    ActiveSheet.Paste
    Selection.RemoveDuplicates Columns:=1, Header:=xlNo
    LastRow6 = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
    '-----------------------------------------------
    'CREATE NEW WORKBOOK AND COPY FILTERED DATA
    With NewWb
    For I = 2 To LastRow6
    WbName = Cells(I, 6).Value
    rng2.Select
    Selection.AutoFilter
    rng2.AutoFilter field:=1, Criteria1:=Cells(I, 6).Value
    rng2.SpecialCells(xlCellTypeVisible).Copy
    Set NewWb = Workbooks.Add(xlWBATWorksheet)
    NewWb.Activate
    ActiveSheet.Paste
    [a2].Select
    ActiveWorkbook.SaveAs Filename:="C:\Users\fanellit\Desktop\" & WbName & ".xlsx"
    Set NewWb = Nothing
    ActiveWorkbook.Close
    CurrentWb.Activate
    Selection.AutoFilter
    [a1].Select
    Next I
    Range(Cells(2, 6), Cells(LastRow6, 6)).ClearContents
    End With
    Last edited by Goa; 2013-10-28 at 04:11.

  2. #2
    Bronze Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,348
    Thanks
    48
    Thanked 273 Times in 251 Posts
    GOA,

    The modified code will filter the list according to distributor and create a PDF for each Distributor along with their associated data. The code will create the subfolder as you described above in D:\Rentreceipt\ with today's date and all the child subfolders beneath it . See the Directory tree below.

    SplitToPDF1.png SplitToPDF3.png

    The D:\Rentreceipt folder must already exist and cannot contain a subfolder with the name of the current date or the code will display a message to remove it.

    SplitToPDF2.png

    Code:
    Public Sub DestinationFilter()
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    'DECLARE AND SET VARIABLES
    Dim rng As Range
    Dim rng2 As Range
    Set CurrentWb = ActiveWorkbook
    LastRow1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Range(Cells(2, 1), Cells(LastRow1, 1))
    Set rng2 = Range("A1:E" & LastRow1)
    '-----------------------------------------------
    'GET LIST OF FILTER CRITERIA
    rng.Copy
    [f2].Select
    ActiveSheet.Paste
    Selection.RemoveDuplicates Columns:=1, Header:=xlNo
    LastRow6 = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
    '-----------------------------------------------
    'CREATE DIRECTORIES< NEW PDF, AND COPY FILTERED DATA
    tdate = Replace(Str(Date), "/", "_")
    MkDir "D:\Rentreceipt\" & tdate
    MkDir "D:\Rentreceipt\" & tdate & "\HouseNo"
    For I = 2 To LastRow6
    wbName = Cells(I, 6).Value
    rng2.Select
    Selection.AutoFilter
    rng2.AutoFilter field:=1, Criteria1:=Cells(I, 6).Value
    MkDir "D:\Rentreceipt\" & tdate & "\HouseNo" & "\00" & I - 1
    MkDir "D:\Rentreceipt\" & tdate & "\HouseNo" & "\00" & I - 1 & "\" & wbName
    Path = "D:\Rentreceipt\" & tdate & "\HouseNo" & "\00" & I - 1 & "\" & wbName & "\"
    Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & wbName & ".pdf", _
        IncludeDocProperties:=False, IgnorePrintAreas:=False
    Selection.AutoFilter
    [a1].Select
    Next I
    Range(Cells(2, 6), Cells(LastRow6, 6)).ClearContents
    Exit Sub
    ErrorHandler:
    MsgBox "Attempting to create subfolder with today's date in the main folder " & _
        "D:\Rentreceipt but it already exist.  Please remove it and try again."
    Range(Cells(2, 6), Cells(LastRow6, 6)).ClearContents
    [a1].Select
    End Sub
    Hope this is what you are looking for,
    Maud
    Attached Files Attached Files
    Last edited by Maudibe; 2013-10-30 at 22:12.

  3. #3
    New Lounger
    Join Date
    Sep 2013
    Posts
    17
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Quote Originally Posted by Maudibe View Post
    The D:\Rentreceipt folder must already exist and cannot contain a subfolder with the name of the current date or the code will display a message to remove it.

    Maud
    Hi Maudibe,
    You Rock on this Forum, Great Man, Thanks for this lovely script.

    I regret for not briefing properly on saving pdf's
    Infact the folder are existing folders & i only need this created pdfs to be saved in those folders.

    Existing path : D:\Rentreceipt\(Todays-date)\HouseNo\001\ only save this wbName.pdf

    Thanks.

  4. #4
    Bronze Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,348
    Thanks
    48
    Thanked 273 Times in 251 Posts
    Thanks Goa. Will make the change shortly.

    Maud

  5. #5
    Bronze Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,348
    Thanks
    48
    Thanked 273 Times in 251 Posts
    Goa,

    I have made the changes. I will assume that the following folders will exist:
    D:\Rentreceipt\(Todays-date)\HouseNo\001\Tom
    D:\Rentreceipt\(Todays-date)\HouseNo\002\Bill
    D:\Rentreceipt\(Todays-date)\HouseNo\003\Fred
    D:\Rentreceipt\(Todays-date)\HouseNo\004\George

    where (Todays-date) is in the format of 10_31_2013 and the date that the code is run is the date that is the name of the folder.

    If the code is run on 11/1/2013 then the folders must be:
    D:\Rentreceipt\11_1_2013\HouseNo\001\Tom

    If the code is run on 11/2/2013 then the folders must be:
    D:\Rentreceipt\11_2_2013\HouseNo\001\Tom

    If the code does not find the folder, it will display the following message:

    SplitToPDF4.png

    Good luck,
    Maud
    Attached Files Attached Files

  6. #6
    New Lounger
    Join Date
    Sep 2013
    Posts
    17
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Hi Maud,
    Thanks for your help, I need to have the header on all the pdf created something like this:
    XYZ Apartments,
    Registerd office: xyxyxy
    Receipt : [copy first cell value here] i.e. for Tom it will Tom , for Bill it be Bill and so on


    Thanks in advance.
    Last edited by Goa; 2013-11-11 at 16:02.

  7. #7
    Bronze Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,348
    Thanks
    48
    Thanked 273 Times in 251 Posts
    Goa,

    I revised the code to place a header on each PDF file which is specific to the name of the distributor. On Sheet1 in Cells A1 and C2, change the Apartment name and Registered Office to the names/values you wish to appear on all the headers. The code will fill in cell C3 with the recipients name. I also set the print button not to be copied to the PDF. Let me know if you need any additional adjustments.

    Maud
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •