(05/12/2023, 11:19)feraz yazdı: Rica ederim,anlamadığınız yer varsa sorabilirsiniz.

teşekkürler. yavaş yavaş çözmeye çalışıyorum kodları.

sadece bir sorum olacak.

reçetelerin olduğu çalışma sayfalarının (sadece seçtiğimiz reçetelerin); Ürün Adı, Türü, Tipi, Formu ve Garanti Edilen İçerik bölümlerini Buton yardımıyla yada başka bir yöntemle PDF yapmak mümkün mü?

Evet bence Pdf yapılabilinir ama bilgim yok pdf ile.

Pdf olarak nasıl görükeceğinin foto sunu atarsanız aklıma gelenyöntemi denerim.

(06/12/2023, 17:09)feraz yazdı: Evet bence Pdf yapılabilinir ama bilgim yok pdf ile.

Pdf olarak nasıl görükeceğinin foto sunu atarsanız aklıma gelenyöntemi denerim.

Sadece seçilmiş olan çalışma sayfalarındaki (Reçete sayfaları) bilgiler pdf olmalı.

Yanlış anlamadıysam gifteki gibi yaptım.
Ve kodlar altta formdaki.Pdf leride masaüstüne kaydettirdim.

(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.

(07/12/2023, 01:11)hnakis yazdı: 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.

Rica ederim.2 adet için kod ile yeni Excel kitabı eklettim orada kod ile 2 adetlik yazdırma alanı yaptırabilirsem ama emin değilim fakat olur zannediyorum.
W/v olayı içindekolay iş.Kodda dikkat ettiyseniz 1 lt ve ürün adı buldurma kodu var.O mantığı w/v içinde uygulatılır yani satır no bulunur ve o hücre boşsa ekletilmez.Ben b:ı sütunlarına kadar aldırmıştım garanti olsun diye hücre birleştirmeden dolayı.
Akşama doğru yapar yollarım dosyayı.