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
