Creating PDF from Worksheet with filter Criteria

[deepak30]

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

[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]

 

[DanteAmor]

Try this

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]

Great Its the only only word that I am getting for you Mr.DanteAmo. Simple Great

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[deepak30]

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

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