kapalı dosyaya veri aktarma

[selcuk23]

Merhabalar, aşağıdaki kodla aynı çalışma içerisindeki sayfaya veri aktarıyorum. bunun üzerinde yapılacak değişiklikle verileri farklı bir klasördeki tabloya veri aktarabilirmiyim.. verileri alt alta kaydedecek şekilde veri aktaracağım dosya yolu :
‪D:\FİİLİ HİZMET ZAMMI\PUANTAJ 5510.xlsm



Private Sub CommandButton4_Click()
Sheets("fazla çalışma izini").Select
If Range("a3") = "" Or Range("e3") = "" Or Range("f4") = "" Then
MsgBox "Eksik Bilgi Girdiniz!" & vbNewLine & "-İsim, İzin Başlayış Tarihi ve İzinli Gün Süresi- verilerini kontrol ediniz!", vbExclamation, "Uyarı"
Exit Sub
Else
adi_soyadi = Sayfa12.Cells(Rows.Count, 2).End(xlUp).Row + 1
Sayfa12.Cells(adi_soyadi, 2).Value = Sheets("fazla çalışma izini").Range("a3").Value
Sayfa12.Cells(adi_soyadi, 2).Offset(0, 1).Value = Sheets("fazla çalışma izini").Range("e3").Value
Sayfa12.Cells(adi_soyadi, 2).Offset(0, 2).Value = Sheets("fazla çalışma izini").Range("f3").Value
Sayfa12.Cells(adi_soyadi, 2).Offset(0, 3).Value = Sheets("fazla çalışma izini").Range("f4").Value
End If
MsgBox "Aktarma işlemi tamamlandı LÜTFEN İZİN TAKİP SAYFASINA GİDİP İZİN TÜRÜNÜ SECİN!", vbInformation, "Bilgi"
End Sub

 

[selcuk23]

Güncel... Oluru var mı bunun acaba

 

[alkazar61]

hocam denemedim ama sanırım böyle birşey işinizi görebilir. bende kapalı bir dosyadan veri çektiğim bir makro kullanıyorum. aynı mantığı kurmaya çalıştım. verileri çektiğiniz kitabın ismini bilmediğim için yazamadım. Sheets("fazla çalışma izini") kısımlarının başına workbooks ismini eklerseniz daha sağlıklı olabilir.

Private Sub CommandButton4_Click()
Application.ScreenUpdating = False
Sheets("fazla çalışma izini").Select
If Range("a3") = "" Or Range("e3") = "" Or Range("f4") = "" Then
MsgBox "Eksik Bilgi Girdiniz!" & vbNewLine & "-İsim, İzin Başlayış Tarihi ve İzinli Gün Süresi- verilerini kontrol ediniz!", vbExclamation, "Uyarı"
Exit Sub
Else
Dim adi_soyadi
Dim Yol
Yol = ‪D:\FİİLİ HİZMET ZAMMI\PUANTAJ 5510.xlsm
Workbooks.Open (Yol)
adi_soyadi = Workbooks("PUANTAJ 5510"). Sayfa12.Cells(Rows.Count, 2).End(xlUp).Row + 1
Workbooks("PUANTAJ 5510"). Sayfa12.Cells(adi_soyadi, 2).Value = Sheets("fazla çalışma izini").Range("a3").Value
Workbooks("PUANTAJ 5510"). Sayfa12.Cells(adi_soyadi, 2).Offset(0, 1).Value = Sheets("fazla çalışma izini").Range("e3").Value
Workbooks("PUANTAJ 5510"). Sayfa12.Cells(adi_soyadi, 2).Offset(0, 2).Value = Sheets("fazla çalışma izini").Range("f3").Value
Workbooks("PUANTAJ 5510"). Sayfa12.Cells(adi_soyadi, 2).Offset(0, 3).Value = Sheets("fazla çalışma izini").Range("f4").Value
End If
Application.ScreenUpdating = True
MsgBox "Aktarma işlemi tamamlandı LÜTFEN İZİN TAKİP SAYFASINA GİDİP İZİN TÜRÜNÜ SECİN!", vbInformation, "Bilgi"
End Sub

 

[selcuk23]

Malesef aktarma yapmadı. hata veriyor .. bilgileri aktaracağı yol :

‪C:\Users\ab141234\Desktop\Kitap1.xlsx

 

[askm]

Yol ="‪C:\Users\ab141234\Desktop\Kitap1.xlsx" şeklinde tırnak içerisinde deneyin.

 

[selcuk23]

Merhabalar, kodu uyarlamaya çalıştım ama beceremedim. dosya üzerinde uygulayabilir misiniz. gerekli bilgileri çalışma içerisine yazdım. dosyayı indirdikten sonra yolu düzenleye bilirim.

http://s3.dosya.tc/server15/dqbea6/Desktop.rar.html

 

[selcuk23]

Konu güncel.

 

[PLİNT]

Merhaba
Ek dosyadaki gibi deneyin
http://www.dosya.tc/server12/97bl4s/Desktop2.zip.html

 

[selcuk23]

Merhaba
Ek dosyadaki gibi deneyin
http://www.dosya.tc/server12/97bl4s/Desktop2.zip.html

Mrh. Maalesef olmadı. Bir hata oluştu uyarısı veriyor,

 

[PLİNT]

Eklediğim dosyada mı hata verdi?
Dosya yolu, dosya adı ve sayfa adında bir eksiklik yoksa hata vermemesi gerekti

https://hizliresim.com/JQg3Rj

[SIZE="2"]Private Sub CommandButton3_Click()
Sheets("İZİN BELGESİ").Select
If Range("a3") = "" Or Range("e3") = "" Or Range("f4") = "" Then
MsgBox "Eksik Bilgi Girdiniz!" & vbNewLine & "-İsim, İzin Başlayış Tarihi ve İzinli Gün Süresi- verilerini kontrol ediniz!", vbExclamation, "Uyarı"
Exit Sub
Else
Dim DOSYA As String
Dim aç, hz
Dim hzs As Worksheet, rw As Long
DOSYA = [COLOR="Blue"]ThisWorkbook.Path & "\" & "PUANTAJ 5510.xlsm[/COLOR]"
Set aç = New Excel.Application
On Error Resume Next
aç.Workbooks.Open DOSYA
Set hz = aç.Workbooks(Dir(DOSYA))
Set hzs = [COLOR="Blue"]hz.Sheets("izin takip")[/COLOR]
rw = hzs.Cells(Rows.Count, "A").End(3).Row + 1
hzs.Range("A" & rw).Value = Range("A3").Value
hzs.Range("B" & rw).Value = Range("E3").Value
hzs.Range("C" & rw).Value = Range("F3").Value
hzs.Range("D" & rw).Value = Range("F4").Value
hz.Close SaveChanges:=True
aç.Quit
Set aç = Nothing: Set hz = Nothing
If Err <> 0 Then
MsgBox "Bir hata oluştu"
Else
MsgBox "Aktarma işlemi tamamlandı!", vbInformation, "Bilgi"
End If
End If

End Sub[/SIZE]

 

[selcuk23]

Teşekkürler, güzel oldu. Emeğinize sağlık,

 

[selcuk23]

Mrh.. Kodu dosyaya uyarlayıp çalıştırdığımda hata vermedi. ancak bugün tekrar açtığımda (Microsoft Excel başka bir uygulamanın OLE eylemini tamamlamasını bekliyor) diyerek donuyor. 10 dakika sonra (Ne yazık ki D:\ C:\users\1234\Deskop\PUANTAJ 5510.xlsm' sitesini acamadık) diye uyarıyor