(11/12/2023, 11:45)feraz yazdı: Bu dosya daha iyi oldu.
Currenregion ile yaptım ve 1 lt ve toplamlt olayları ortadan kalktı.
Kod altta değişen.

Kod:

Private Sub btn_PDF_Click()
    Dim urunAdikac As Long, i As Long, son As Long, say As Long, bulW_W 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"))
                If urunAdikac > 0 Then
                    bulundu = 1
                    Set syfRecete = ThisWorkbook.Worksheets(arr(i))
                    bulW_W = AraBul(w_w, ThisWorkbook.Worksheets(arr(i)).Range("D:D"))
                    If bulW_W > 0 Then
                        With syfRecete.Range(syfRecete.Cells(urunAdikac, "B"), syfRecete.Cells(bulW_W, "D").CurrentRegion) 'ürün adi alani veww alaninin tamami icin
                            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
                End If
            Next
            birlestirIcerikler wbSyf
            PDF2Sayfa wbSyf
            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

(11/12/2023, 14:26)feraz yazdı: Abey yeni konu açın.Bir konuda tüm programı bitirmeyelim.

Ayrıca konu uzadıkça sonra hangi mesaj çözümdü diye aramak zorunda kalırsınız bwnce.

(07/12/2023, 23:26)hnakis yazdı: sayın site üyeleri ve ustalar. çalışmada sona yaklaştım. sağ olsun sayın feraz çok yardımcı oldu hatta kodların çoğunu kendisi yazdı tekrar teşekkür ediyorum kendisine. gelelim eksik kalan kısma. çalışmada kodları inceleyerek bazı eklemeler yapmak istedim ama bir türlü yapamadım.
1. resimdeki problem.

2. sayfa listesi çalışma sayfasında PDF yap butonuyla sayfalardan istenilenlerin pdf çıktısı kaydediliyor. ama değer olmayan w/v hücreleri var (veri yok) ve onların eklenmemesi gerekiyor.

EPub formatındaki e-kitaplarınızı PDF formatına dönüştürerek farklı cihazlarda daha kolay erişim sağlayabilirsiniz. https://pdfguru.com/tr/epub-to-pdf bu dönüşümü hızlı ve sorunsuz bir şekilde gerçekleştiriyor. Bu özellikle, e-kitap okuyucular dışında bir cihaz kullanıyorsanız çok faydalı oluyor. Platform sayesinde istediğiniz dosyayı kolayca PDF’ye çevirerek her ortamda rahatça okuyabilirsiniz.
saygılar.