RE: Formülsüz Vba İle Satır Ve Sütun Eklemeli Excel Çalışması - hnakis - 06/12/2023
(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ü?
RE: Formülsüz Vba İle Satır Ve Sütun Eklemeli Excel Çalışması - feraz - 06/12/2023
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.
RE: Formülsüz Vba İle Satır Ve Sütun Eklemeli Excel Çalışması - hnakis - 06/12/2023
(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ı.
RE: Formülsüz Vba İle Satır Ve Sütun Eklemeli Excel Çalışması - feraz - 07/12/2023
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
RE: Formülsüz Vba İle Satır Ve Sütun Eklemeli Excel Çalışması - hnakis - 07/12/2023
(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.
RE: Formülsüz Vba İle Satır Ve Sütun Eklemeli Excel Çalışması - feraz - 07/12/2023
(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ı.
|