• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Bir Kolondaki Verileri Baska Dosyaya Alip PDF Olarak Kaydetme

T

tolgatrb

Katılım
13 Eylül 2011
Mesajlar
11
Excel Vers. ve Dili
türkçe 2010
Merhaba

Elimde 2 adet dosya var. Bunlardan biri kablo karti dedigimiz dosya.

Kablo karti dosyasinda D21 hucresine kablo adini yaziyorum ve baska bir sheetten kablo ozelliklerini aliyor. ben bir makro ile bu sayfayi pdf olarak kaydediyorum.

Fakat benim istedigim benim sececegim excel dosyasini tarayip, D2 hucresinden baslayip D kolonun sonuna kadar, hangi hucrede kablo ismi varsa hepsi icin ayri ayri kablo karti olusturup bunu pdf olarak kaydetmesi.

Umarim aciklayici olmustur. yardimlariniz icin simdiden tesekkurler
 
Örnek dosya ekler misiniz.
 
Veri alınacak çalışma kitabında 3 tane sayfa mevcut. Bunların üçünden de veri alınacak mı yoksa hangisinden.
 
dosyayi tek sheet olarak dusunebilirsiniz. ben bu sheetleri ayri calisma kitaplarina bolecegim.
 
Aşağıdaki kodları deneyin.
Kod: 
Sub ASKM_Veri_Cek()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Card -node"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "Heat Trace Metering.xlsx"
'SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To SonSatir
    Workbooks(aktif_Ktp).Sheets(Kayit_syf).Range("D21") = Workbooks(dosya).Sheets(1).Range("D" & x)
    PDF_Kaydet
Next

Workbooks(dosya).Save
Workbooks(dosya).Close

ActiveWorkbook.Save
MsgBox "Kayıt işlemi tamamlandı...", vbInformation, "A S K M"
End Sub

Sub PDF_Kaydet()
Dim sh As Worksheet
Set sh = Worksheets("Card -node")
yol = ThisWorkbook.Path
isim = sh.Range("d21").Value & "-" & Format(Now, "yyyy-mm-dd-hh-mm")
sh.Select
sh.Range("B2:P70").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol _
& "\" & isim & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
 
askm' Alıntı:
Aşağıdaki kodları deneyin.
Kod: 
Sub ASKM_Veri_Cek()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Card -node"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "Heat Trace Metering.xlsx"
'SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To SonSatir
    Workbooks(aktif_Ktp).Sheets(Kayit_syf).Range("D21") = Workbooks(dosya).Sheets(1).Range("D" & x)
    PDF_Kaydet
Next

Workbooks(dosya).Save
Workbooks(dosya).Close

ActiveWorkbook.Save
MsgBox "Kayıt işlemi tamamlandı...", vbInformation, "A S K M"
End Sub

Sub PDF_Kaydet()
Dim sh As Worksheet
Set sh = Worksheets("Card -node")
yol = ThisWorkbook.Path
isim = sh.Range("d21").Value & "-" & Format(Now, "yyyy-mm-dd-hh-mm")
sh.Select
sh.Range("B2:P70").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol _
& "\" & isim & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
Genişletmek için tıkla ...

run time error 9
subscript out of range
hatasi aliyorum
 
Hangi satırda hata alıyorsunuz.
 
Kod: 
Sub ASKM_Veri_Cek()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Card -node"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "Heat Trace Metering.xlsx"
'SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To SonSatir
    Workbooks(aktif_Ktp).Sheets(Kayit_syf).Range("D21") = Workbooks(dosya).Sheets(1).Range("D" & x)
    Workbooks(aktif_Ktp).Activate
    PDF_Kaydet
    
Next

Workbooks(dosya).Save
Workbooks(dosya).Close

ActiveWorkbook.Save
MsgBox "Kayıt işlemi tamamlandı...", vbInformation, "A S K M"
End Sub

Sub PDF_Kaydet()
Dim sh As Worksheet
Set sh = Worksheets("Card -node")
yol = ThisWorkbook.Path
isim = sh.Range("d21").Value & "-" & Format(Now, "yyyy-mm-dd-hh-mm")
sh.Select
sh.Range("B2:P70").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol _
& "\" & isim & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

End Sub
 
askm' Alıntı:
Kod: 
Sub ASKM_Veri_Cek()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Card -node"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "Heat Trace Metering.xlsx"
'SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To SonSatir
    Workbooks(aktif_Ktp).Sheets(Kayit_syf).Range("D21") = Workbooks(dosya).Sheets(1).Range("D" & x)
    Workbooks(aktif_Ktp).Activate
    PDF_Kaydet
    
Next

Workbooks(dosya).Save
Workbooks(dosya).Close

ActiveWorkbook.Save
MsgBox "Kayıt işlemi tamamlandı...", vbInformation, "A S K M"
End Sub

Sub PDF_Kaydet()
Dim sh As Worksheet
Set sh = Worksheets("Card -node")
yol = ThisWorkbook.Path
isim = sh.Range("d21").Value & "-" & Format(Now, "yyyy-mm-dd-hh-mm")
sh.Select
sh.Range("B2:P70").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol _
& "\" & isim & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

End Sub
Genişletmek için tıkla ...


su anda calisiyor fakat bir kac tane kaydettikten sonra "Run Time Error 1004 - Document Not Saved. the document may be open or an error may have been encountered when saving' hatasi aliyorum
 
askm' Alıntı:
Kod: 
Sub ASKM_Veri_Cek()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Card -node"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "Heat Trace Metering.xlsx"
'SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To SonSatir
    Workbooks(aktif_Ktp).Sheets(Kayit_syf).Range("D21") = Workbooks(dosya).Sheets(1).Range("D" & x)
    Workbooks(aktif_Ktp).Activate
    PDF_Kaydet
    
Next

Workbooks(dosya).Save
Workbooks(dosya).Close

ActiveWorkbook.Save
MsgBox "Kayıt işlemi tamamlandı...", vbInformation, "A S K M"
End Sub

Sub PDF_Kaydet()
Dim sh As Worksheet
Set sh = Worksheets("Card -node")
yol = ThisWorkbook.Path
isim = sh.Range("d21").Value & "-" & Format(Now, "yyyy-mm-dd-hh-mm")
sh.Select
sh.Range("B2:P70").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol _
& "\" & isim & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

End Sub
Genişletmek için tıkla ...

aslinda soyle birsey yaparsak cok daha kolay olur sanirim. kablo karti dosyamiza yeni bir sheet ekleyelim. ve oraya ekledigimiz bir butona tikladigimizda, a kolonuna kopyaladigimiz verileri tek tek yapistirip pdfleri alsin. bunu hazirlayip dosyayi gonderme sansiniz olursa cok sevinirim.
 
Kod bende çalışıyor. Dilerseniz kodun başına tanımlardan sonra on error resume next satırı ekleyin.Bir de hemen altına Application.DisplayAlerts = False yazarsanız düzelir.
Yani
Kod: 
Sub ASKM_Veri_Cek()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Card -node"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "Heat Trace Metering.xlsx"

on  error resume next
Application.DisplayAlerts = False

'SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To SonSatir
    Workbooks(aktif_Ktp).Sheets(Kayit_syf).Range("D21") = Workbooks(dosya).Sheets(1).Range("D" & x)
    Workbooks(aktif_Ktp).Activate
    PDF_Kaydet
    
Next

Workbooks(dosya).Save
Workbooks(dosya).Close

ActiveWorkbook.Save
MsgBox "Kayıt işlemi tamamlandı...", vbInformation, "A S K M"
End Sub

Sub PDF_Kaydet()
Dim sh As Worksheet
Set sh = Worksheets("Card -node")
yol = ThisWorkbook.Path
isim = sh.Range("d21").Value & "-" & Format(Now, "yyyy-mm-dd-hh-mm")
sh.Select
sh.Range("B2:P70").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol _
& "\" & isim & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

End Sub
 
askm' Alıntı:
Kod bende çalışıyor. Dilerseniz kodun başına tanımlardan sonra on error resume next satırı ekleyin.Bir de hemen altına Application.DisplayAlerts = False yazarsanız düzelir.
Yani
Kod: 
Sub ASKM_Veri_Cek()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Card -node"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "Heat Trace Metering.xlsx"

on  error resume next
Application.DisplayAlerts = False

'SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To SonSatir
    Workbooks(aktif_Ktp).Sheets(Kayit_syf).Range("D21") = Workbooks(dosya).Sheets(1).Range("D" & x)
    Workbooks(aktif_Ktp).Activate
    PDF_Kaydet
    
Next

Workbooks(dosya).Save
Workbooks(dosya).Close

ActiveWorkbook.Save
MsgBox "Kayıt işlemi tamamlandı...", vbInformation, "A S K M"
End Sub

Sub PDF_Kaydet()
Dim sh As Worksheet
Set sh = Worksheets("Card -node")
yol = ThisWorkbook.Path
isim = sh.Range("d21").Value & "-" & Format(Now, "yyyy-mm-dd-hh-mm")
sh.Select
sh.Range("B2:P70").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol _
& "\" & isim & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

End Sub
Genişletmek için tıkla ...

ellerinize sagli. peki bir onceki mesajimda belirttigim gibi yapmak istersem ne yapmam gerekir.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst