(07/12/2023, 00:12)feraz yazdı: Yanlış anlamadıysam gifteki gibi yaptım.
Ve kodlar altta formdaki.Pdf leride masaüstüne kaydettirdim.

Kod:

Private Sub btn_PDF_Click()
    Dim urunAdikac As Long, BirLTKac As Long, i As Long, son As Long, say As Long
    Dim syf As Worksheet, wb As Workbook, wbSyf As Worksheet, syfRecete As Worksheet, bulundu As Byte, yol As String
   
    Set syf = ThisWorkbook.Worksheets("SayfaListeleri")
   
    With Me.ListBox1
        If .ListCount = 0 Then Exit Sub
        ReDim arr(1 To 1)
        say = 0: bulundu = 0
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
            say = say + 1
            ReDim Preserve arr(1 To say)
            arr(say) = .List(i)
            End If
        Next
       
        If say > 0 Then
            Set wb = Workbooks.Add
            Set wbSyf = wb.Worksheets(1)
            wbSyf.Name = "PDF"
            Application.ScreenUpdating = False
            For i = 1 To say
                urunAdikac = AraBul(UrunAdi, ThisWorkbook.Worksheets(arr(i)).Range("B:B"))
                BirLTKac = AraBul(birLT, ThisWorkbook.Worksheets(arr(i)).Range("B:B"))
                If urunAdikac > 0 And BirLTKac > 0 Then
                    bulundu = 1
                    Set syfRecete = ThisWorkbook.Worksheets(arr(i))
                    With syfRecete.Range(syfRecete.Cells(urunAdikac, "B"), syfRecete.Cells(BirLTKac, "I"))
                        If i = 1 Then
                            .Copy wbSyf.Cells(Rows.Count, 1).End(3)(2, 1) '2 tek satir atlama icin
                        ElseIf i > 1 Then
                            .Copy wbSyf.Cells(Rows.Count, 1).End(3)(4, 1) '4 üc satir atlama icin
                        End If
                    End With
                End If
            Next
            Application.ScreenUpdating = True
            wbSyf.Columns.AutoFit
            Application.CutCopyMode = False
           
            If bulundu > 0 Then
                yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Format(Now, "dd-mm-yyyy --- hh_mm_ss")
                wbSyf.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True

                Set obj = CreateObject("Shell.Application")
                If Dir(yol & ".pdf") <> "" Then obj.ShellExecute (yol & ".pdf")
                Set obj = Nothing
            End If
        End If
    End With
   
    On Error Resume Next
    Application.CutCopyMode = False
    Erase arr
    wb.Close 0
    Set syf = Nothing: Set wbSyf = Nothing: Set wb = Nothing
End Sub

Private Sub Chk_Hepsi_Change()
    Dim i As Long
    If Me.ListBox1.ListCount = 0 Then Exit Sub
    For i = 0 To Me.ListBox1.ListCount - 1
        Me.ListBox1.Selected(i) = Me.Chk_Hepsi.Value
    Next
End Sub

Private Sub UserForm_Initialize()

    Dim i As Long, son As Long, say As Long
    Dim lstbox As MSForms.ListBox
   
    Set lstbox = Me.ListBox1
    With ThisWorkbook.Worksheets("SayfaListeleri")
        son = .Cells(Rows.Count, "A").End(3).Row
        If son < 2 Then Exit Sub
        With lstbox
            .Clear
            .ListStyle = fmListStyleOption
            .MultiSelect = fmMultiSelectExtended
        End With
       
        ReDim arr(1 To son): If son < 2 Then Exit Sub: say = 0
       
        For i = 2 To son
            say = say + 1
            ReDim Preserve arr(1 To say)
            arr(say) = .Cells(i, "A").Value
        Next
    End With
   
    If say > 0 Then lstbox.List = arr
   
    On Error Resume Next
    Erase arr
    Set lstbox = Nothing
End Sub

çok güzel olmuş sayın feraz. elinize sağlık. bende bazı eklemeler yaptım çalışmaya. çok güzel oldu tamamı.

her pdf sayfasına sadece 2 adet reçete gelmesi nasıl olur. birde w/v kısmı boşsa pdf' de bu kısım görünmese. kodu biraz inceledim ama açıkçası pek anlayamadım.