Creating PDF from Worksheet with filter Criteria

deepak30

New Member
Joined
May 11, 2020
Messages
38
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
Hello Sir

Below Macro was ok until my Data sheet (Sheet2) was below 1000
But now I have 400 records in 1st Master sheet (call it as sheet1 ) and 50000+ records in Data Sheet (call it as sheet2)
Now i do not want that it should loop through sheet1 find the value in sheet2 and if found then filter it and create PDF

Now I want that if filter is given in sheet1 it will loop only through visible cells and filter data in sheet2 create pdf name that pdf file as per cell name and mention its path +name in sheet1 so that i can be mail later
if filter is not given then it will loop all else loop only visible data of sheet1

Please Help me where the code is to be changed and how


VBA Code:
[CODE=vba]Sub splitfile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, fn As range, sr As range, rng As range, n As Long, path As String, folder As String
Sheets("data").Select
Dim FilterCol As String: FilterCol = "B" 'The column containing the data to filter by
Dim HeaderRow As String: HeaderRow = "1" 'The row containing headers for the data
Set rngToFilter = range(FilterCol & HeaderRow, Cells(Rows.Count, FilterCol).End(xlUp))
Sheets("Master").Select
path = range("J3").Value
Set sh1 = Sheets("master")
Set sh2 = Sheets("Data")
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
lrfn = lr + 1
Sheets("data").Select
For i = lr To 2 Step -1
    Set fn = sh2.range("B:B").Find(sh1.Cells(i, 1).Value, , xlValues, xlWhole)
    Application.StatusBar = "Processing Left... " & CInt(i / lrfn * 100) & "% " & String(CInt(i / lrfn * 100), ChrW(9609))
    If Not fn Is Nothing Then
        Set sr = fn.Offset(1, 1)
        If sr <> "" And sr.Offset(1) <> "" Then
            Set er = sr.End(xlDown)
            Set rng = sh2.range(sr, er)
        Else
            Set rng = sr
        End If
        n = rng.Rows.Count
        Sheets("data").Select
        With ActiveWorkbook.Sheets("data")
            rngToFilter.AutoFilter Field:=2, Criteria1:=fn.Value
        End With
        activesheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=path & fn.Value & ".pdf", _
        quality:=xlQualityStandard, includedocproperties:=True, _
        ignoreprintareas:=False, openafterpublish:=False
        
        activesheet.AutoFilter.ShowAllData
        
        lrow = activesheet.Cells(Rows.Count, 2).End(xlUp).Row
        Sheets("Master").Select
        ThisWorkbook.Sheets("Master").Cells(i, 4) = path & fn.Value & ".pdf"
        ThisWorkbook.Sheets("Master").Cells(i, 5) = "Pending"
        ThisWorkbook.Sheets("Master").Cells(i, 7) = lrow - 1
    End If
Next
'Call createpdf
range("A2").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/CODE]
 

Some videos you may like

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,619
Office Version
  1. 2007
Platform
  1. Windows
Try this

VBA Code:
Sub splitfile()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, lr As Long, lrfn As Long
  Dim fn As Range
  Dim sPath As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.StatusBar = False
  
  Set sh1 = Sheets("master")
  Set sh2 = Sheets("Data")
  
  sPath = sh1.Range("J3").Value
  
  lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
  lrfn = WorksheetFunction.CountA(sh1.Range("A1:A" & lr).SpecialCells(xlCellTypeVisible)) - 1
  For i = lr To 2 Step -1
    If sh1.Range("A" & i).EntireRow.Hidden = False Then
      sh2.AutoFilter.ShowAllData
      Set fn = sh2.Range("B:B").Find(sh1.Range("A" & i).Value, , xlValues, xlWhole)
      Application.StatusBar = "Processing Left... " & CInt(i / lrfn * 100) & "% " & String(CInt(i / lrfn * 100), ChrW(9609))
      If Not fn Is Nothing Then
        sh2.Range("B1", sh2.Range("B" & Rows.Count).End(3)).AutoFilter 1, fn.Value
        sh2.ExportAsFixedFormat xlTypePDF, sPath & fn.Value & ".pdf", 0, True, False, , , False
        
        sh1.Range("D" & i) = sPath & fn.Value & ".pdf"
        sh1.Range("E" & i) = "Pending"
        sh1.Range("G" & i) = sh2.Cells(Rows.Count, 2).End(xlUp).Row - 1
      End If
    End If
  Next
  sh2.AutoFilter.ShowAllData
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.StatusBar = False
End Sub
 

deepak30

New Member
Joined
May 11, 2020
Messages
38
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
Great Its the only only word that I am getting for you Mr.DanteAmo. Simple Great
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,619
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

deepak30

New Member
Joined
May 11, 2020
Messages
38
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
Hi
I need one more help
I am converting PDF to work using foxit to convert pdf to word ( and i donot have any lib for foxit so do not use any function on foxit)

i have done everything now
1. I want to close only the open file in foxit and minimized the foxit application from the excel vba
2. I donot know the conversion time of pdf to word so it will close only when the application has done its given job

Code:
Sub ExtracPDFData()
Dim pdfapp, FileName As Variant
Dim PDFFolder, ExportFile As String
Dim ClientRow, CustCol, DataCol, DataRow, LastRow As Long
pdfapp = Shell("C:\Program Files\Foxit Software\Foxit PhantomPDF\FoxitPhantomPDF.exe", vbNormalFocus)
With Sheet1
    If Sheet1.Range("c6").Value = Empty Then
        MsgBox "Please Select your PDF File"
        GetSelectedPath
    End If
    ExportFile = .Range("c6").Value
    FileName = ExportFile
End With

' CALL PATH NAME FROM SHEET1 C6 CELL
pdfapp = Shell("C:\Program Files\Foxit Software\Foxit PhantomPDF\FoxitPhantomPDF.exe """ & FileName & """", vbNormalFocus)
On Error Resume Next
AppActivate (pdapp)
On Error GoTo 0
Application.Wait Now + 0.0001
Application.SendKeys "%k", True
Application.Wait Now + 0.00001
Application.SendKeys "{home}", True
Application.Wait Now + 0.00001
Call SendKeys("d:\pankaj excel program\", True)
Application.SendKeys "%g", True
Application.Wait Now + 0.000001
Application.SendKeys "%p", True
Application.Wait Now + 0.000001
Application.SendKeys "{tab}", True
Application.Wait Now + 0.000001
Call SendKeys("2-100", True)
Application.SendKeys "%p", True
Application.Wait Now + 0.000001
Application.SendKeys "%k", True
Application.Wait Now + 0.000001
Application.SendKeys "%s", True
Application.Wait Now + 0.000001
Application.SendKeys "%y", True
Application.Wait Now + 0.000001
Application.SendKeys "{NUMLOCK}%s"
Application.Wait Now + 0.00005
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,128,140
Messages
5,628,937
Members
416,354
Latest member
JojoMaque

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top