Ekstre alma

[TİKOS]

Merhaba
ekte bir dosyam var. Bu dosyada bir buton yapıp G3 Hücresindeki isim ile yeni
bir excel sayfası açıp sheetdeki tüm bilgileri oraya kopyalasın.
Yardımcı olursanız çok sevinirim.

 

[TİKOS]

Excel sayfası yerine PDF olarak açabilirmi

 

[TİKOS]

arkadaşlar yardım rica ediyorum

 

[halit3]

Dosyanın yanına sayfayı kopyalıyor.

Sub Bu_Sayfayı_Çalışma_Kitabı()

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya = ThisWorkbook.FullName
uzanti = "." & fL.GetExtensionName(dosya)


Kaynak = ThisWorkbook.Path
dosya_adi = Cells(3, "g").Value

If CreateObject("Scripting.FileSystemObject").FileExists(Kaynak & "\" & dosya_adi & uzanti) = True Then
MsgBox "Bu isimde bir dosya var"
Exit Sub
End If

ThisWorkbook.ActiveSheet.Copy

For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)

If ModX.Type = 100 Then
VBComp.CodeModule.DeleteLines 1, VBComp.CodeModule.CountOfLines
Else
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
End If
Next

ActiveSheet.DrawingObjects.Delete

If Val(Application.Version) >= 12 Then
ActiveWorkbook.SaveAs Kaynak & "\" & dosya_adi & uzanti, FileFormat:=52 '51
Else
ActiveWorkbook.SaveAs Kaynak & dosya_adi & "\" & uzanti, FileFormat:=-4143 '56 ' xlExcel9795
End If
ActiveWorkbook.Close False

MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"

 

[TİKOS]

hocam çok teşekkürler
PDF olarak desktop'a kopyalayabilirmi

 

[TİKOS]

ben yapamadım hocam
dosya üstünde yapabilirmisiniz

 

[acar6783]

Sub pdfkaydet()

Set kls = CreateObject("Scripting.FileSystemObject")
Set cl = Sheets("CariListesi")
Set sb = Sheets("Şablon")

cariad = cl.Cells(ActiveCell.Row, "B")


    yol = ThisWorkbook.Path & "\Gönderilmiş\" & cariad
  varmı = kls.FolderExists(yol)
  If varmı = False Then kls.CreateFolder yol

    isim = cariad & "_" & Format(Date, "dd.mm.yyyy")

On Error GoTo hata
    sb.Range("A1:K45").ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
    yol & "/" & isim & ".pdf", _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=True
        
        Exit Sub
hata:
   
If MsgBox("Bu Bilgisayarda Pdf Eklentisi Mevcut Değil" & Chr(13) & "Eklenti Kurulsun mu ? ", vbYesNo, "Uyarı") = vbYes Then
Shell ThisWorkbook.Path & "\saveaspdf\" & "SaveAsPDF.exe"
Else: Exit Sub
            
End If

End Sub

Bu kodları kendinize göre uyarlayabilirsiniz..
Pdf eklentisi kurulu değilse hata verecektir.Dosyanızın olduğu klsöre Ekteki Eklentiyi indiriniz.

 

[TİKOS]

çok teşekkürler
ellerinize sağlık