Formülsüz Vba İle Satır Ve Sütun Eklemeli Excel Çalışması

1 2 3 4 5 6 7 8
06/12/2023, 14:59

hnakis

(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ü?
06/12/2023, 17:09

feraz

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, 18:43

hnakis

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


07/12/2023, 00:12

feraz

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
(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ı.
1 2 3 4 5 6 7 8