VBA Filter From Named Range

[Aviles]

Hi all, couldn't find an answer to my specific question so I'm hoping some one can assist.

I have a range of data in Sheet1 from A1:T5000. I have a Named Range called "Doc" which I have created in Sheet2.

Here is an example of what Column A looks like in Sheet1:

Column A
Name1
Data1
Data2
Data3
Name2
Data1
Data2
Data3
Data4
Data5
Name3
Data1
Data2

What I am looking to do is:

1. Apply a filter using the named ranges contained in Column A (Sheet1) while also capturing the rows directly below the names (just before getting to the next name).

So the first filter would look like below, and also include all the corresponding columns up to Column T:

Name1
Data1
Data2
Data3

2. Copy this information and paste to Sheet3, cell B12

3. Save Sheet3 as a PDF

4. Go back to Sheet1 and repeat steps for the next name in the range from Column A:

Name2
Data1
Data2
Data3
Data4
Data5

...and so on until all the names from Column A (Sheet1) with corresponding rows have been moved to Sheet3 and saved as a PDF.

Hopefully this makes sense and some one can help me out as I have no idea how to approach this.

Thanks in advance.

 

[igold]

I have a question:

Is Name1, Name2, Name3 and so on, the data that makes up your Named Range "Doc", and is that the only data that is contained in that Named Range. Also, are you trying to save a Sheet3 for every single name and data that is copied to B12, winding up with as many sheets as there are names.

 

[Aviles]

I have a question:

Is Name1, Name2, Name3 and so on, the data that makes up your Named Range "Doc", and is that the only data that is contained in that Named Range. Also, are you trying to save a Sheet3 for every single name and data that is copied to B12, winding up with as many sheets as there are names.

Hi igold, thanks for taking a look at this.

Yes, there are currently 14 names in the "Doc" Named Range and that is the only data contained in the Named Range. Although not very often, the names on this Named Range can change, but if they do, the names will no longer appear on Sheet1. Also it might be worth noting that not all the names in the Named Range will appear in Sheet1. Most of the time they will, but there will be times where Sheet1 only contains some of the names in the Named Range.

Yes, I would like to save Sheet3 for every single name and corresponding data that is copied to B12. So in this current version, I would end up with 14 different PDF sheets for each name.

Please let me know if you need anything else.

Thanks.

 

[igold]

Not using a filter, see if this is close to what you are looking for. The PDF's will be saved to the Excel Default File Path and will be named by the corresponding name in the Named Range.

Sub test()
    
    Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
    Dim ws3 As Worksheet: Set ws3 = Worksheets("Sheet3")
    Dim colA As Range
    Dim lRow As Long, n As Long, rw As Long
    Dim Da, ele
    
    Application.ScreenUpdating = False
    ws1.Activate
    Da = Application.Transpose(ws2.Range("Doc"))
    lRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Set colA = ws1.Range("A1:A" & lRow)
    For n = colA.Cells.Count To 1 Step -1
        ele = Application.Match(colA.Cells(n), Da, False)
        If Not IsError(ele) Then
            rw = colA.Cells(n).Row
            Range("A" & rw & ":T" & lRow).Copy ws3.Range("B12")
            ws3.Activate
            ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=Da(ele), _
            Quality:=xlQualityStandard, _
            Includedocproperties:=False, _
            ignoreprintareas:=False, _
            openafterpublish:=False
            Range("B12").Resize(lRow - rw + 1, 20).ClearContents
            lRow = rw - 1
            ws1.Activate
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Operation Complete"
    
End Sub

I hope this helps.

 

[Aviles]

Not using a filter, see if this is close to what you are looking for. The PDF's will be saved to the Excel Default File Path and will be named by the corresponding name in the Named Range.

Sub test()
    
    Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
    Dim ws3 As Worksheet: Set ws3 = Worksheets("Sheet3")
    Dim colA As Range
    Dim lRow As Long, n As Long, rw As Long
    Dim Da, ele
    
    Application.ScreenUpdating = False
    ws1.Activate
    Da = Application.Transpose(ws2.Range("Doc"))
    lRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Set colA = ws1.Range("A1:A" & lRow)
    For n = colA.Cells.Count To 1 Step -1
        ele = Application.Match(colA.Cells(n), Da, False)
        If Not IsError(ele) Then
            rw = colA.Cells(n).Row
            Range("A" & rw & ":T" & lRow).Copy ws3.Range("B12")
            ws3.Activate
            ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=Da(ele), _
            Quality:=xlQualityStandard, _
            Includedocproperties:=False, _
            ignoreprintareas:=False, _
            openafterpublish:=False
            Range("B12").Resize(lRow - rw + 1, 20).ClearContents
            lRow = rw - 1
            ws1.Activate
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Operation Complete"
    
End Sub

I hope this helps.

Hi igold,


That code works really well and I want to say thank you so much for taking the time to help me out, I really appreciate it.


If it's not too much trouble, would you be able to add the below two steps to the code please?


1. Instead of saving the PDF files to the Excel default file path, could I save it to a specific path: H:\Miscellaneous\Projects\


2. For the name of the PDF files, could you format it to be named: "Name1 - Fortnight Ending yyyy/mmm/dd" where the date is the current date (date report run)


Thanks in advance.

 

[igold]

Thanks for the feedback. Try this... I could not use the date as you had it formatted. Instead of the "/", I had to use "-".

Sub test()
    
    Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
    Dim ws3 As Worksheet: Set ws3 = Worksheets("Sheet3")
    Dim colA As Range
    Dim lRow As Long, n As Long, rw As Long
    Dim Da, ele
    Dim dt As String, sFile As String
    
    Application.ScreenUpdating = False
[COLOR=#ff0000]    dt = Format(Date, "yyyy-mmm-dd")[/COLOR]
    ws1.Activate
    Da = Application.Transpose(ws2.Range("Doc"))
    lRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Set colA = ws1.Range("A1:A" & lRow)
    For n = colA.Cells.Count To 1 Step -1
        ele = Application.Match(colA.Cells(n), Da, False)
        If Not IsError(ele) Then
            sFile = "H:\Miscellaneous\Projects" & "\" & Da(ele) & " - Fortnight Ending " & dt
            rw = colA.Cells(n).Row
            Range("A" & rw & ":T" & lRow).Copy ws3.Range("B12")
            ws3.Activate
            ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sFile, _
            Quality:=xlQualityStandard, _
            Includedocproperties:=False, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
            Range("B12").Resize(lRow - rw + 1, 20).ClearContents
            lRow = rw - 1
            ws1.Activate
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Operation Complete"
    
End Sub