• DİKKAT

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

Makro-VBA Aktarma

Y

yusufcam

Katılım
6 Aralık 2006
Mesajlar
72
Excel Vers. ve Dili
2007 turkce
İyi Çalışmalar
Bir excel çalışma kitabında formüller içeren değerler var bu değerleri aynı başlıklar altındaki başka bir excel çalışma kitabına formüleri almadan ve kopyala yapıştır kullanmadan, butonla kod yazarak aktara bilirmiyim ne yapmam lazım. teşekkürler
 
Son düzenleme:
Sayın YusufCam öncelikle başlığınızı değiştirirseniz sonradan arandığında daha kolay ulaşılır. Bir de örnek dosya ekleyip açıklarsanız, dilediğiniz bilgiler aktaracak kod yazılır.
 
Aktarma

1.xls çalışma kitabı formül içeriyor. Başka yerden değerler alıyor. ben bunu formül süz olarak 2.xls kitabına 1.xls kitabındaki butonla aktarmak istiyorum
 

Ekli dosyalar

  • 2.xls
    2.xls
    214 KB · Görüntüleme: 3
  • 1.xls
    1.xls
    43.5 KB · Görüntüleme: 2
2.kitaptaki bilgiler kalıp altına mı eklenecek, yoksa onları silerek sıfırdan mı ekleyecek.
 
Aşağıdaki kodları deneyin.
Kod: 
Option Explicit
Private Sub CommandButton1_Click()
Dim aktif_Ktp, SayfaAdi, Kayit_syf, i, k
Dim SonSatir
Dim SonSat
SonSat = Range("A65536").End(xlUp).Row
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Sayfa1"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "2.xls"
SayfaAdi = "Sayfa1"
Workbooks.Open (dosya_yeri & dosya)
' Workbooks(dosya).Sheets(SayfaAdi).Range("A3:AH1000000").ClearContents 'Silmek için
For i = 3 To SonSat
SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1
    For k = 1 To 34
        Workbooks(dosya).Sheets(SayfaAdi).Cells(SonSatir, k) = Workbooks(aktif_Ktp).Sheets("Sayfa1").Cells(i, k)
    Next k
Next i
Workbooks(dosya).Save
Workbooks(dosya).Close
MsgBox "Aktarma işlemi tamamlandı..." & Chr(10) & Chr(10) & "İyi çalışmalar...", vbInformation, "ASKM"
End Sub
 
Workbooks(dosya).Sheets(SayfaAdi).Range("A3:AH65000").ClearContents 'Silmek için satır aktif ve bu şekilde olması gerekiyor. 97 uyumlu kayıt yaparsanız hata verir. 2010 ve üstünde satır sayısı fazla olduğu için hata vermez ama eski versiyonda 65000 civarı satır olduğundan hata verir.
 
Merhaba.

İkinci satırdaki kullanım sorunsuz çalışır.
Kod: 
SonSat = Range("A[B][COLOR="Red"]65536[/COLOR][/B]").End(xlUp).Row
SonSat = Cells([B][COLOR="Blue"]Rows.Count[/COLOR][/B],"A").End(xlUp).Row
 
O vakit kodları şu şekilde revize edelim.
Kod: 
Option Explicit
Private Sub CommandButton1_Click()
Dim aktif_Ktp, SayfaAdi, Kayit_syf, i, k
Dim SonSatir
Dim SonSat
SonSat = Cells(Rows.Count,"A").End(xlUp).Row
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Sayfa1"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "2.xls"
SayfaAdi = "Sayfa1"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks(dosya).Sheets(SayfaAdi).Range("A3:A" & SonSatir).ClearContents 'Silmek için
For i = 3 To SonSat
    For k = 1 To 34
        Workbooks(dosya).Sheets(SayfaAdi).Cells(SonSatir, k) = Workbooks(aktif_Ktp).Sheets("Sayfa1").Cells(i, k)
    Next k
Next i
Workbooks(dosya).Save
Workbooks(dosya).Close
MsgBox "Aktarma işlemi tamamlandı..." & Chr(10) & Chr(10) & "İyi çalışmalar...", vbInformation, "ASKM"
End Sub
 
iyi aksamlar
son verdiğiniz kodlar aktar dediğimde sadece son satırı aktarıyor.
ilkinde de aktarıyor fakat tekrar akta dediğimde aynı değerleri son satırın altına tekrar atıyor
 
sonradır kısmını for K=1 satırından sonra yazarsanız olur.
 
Kod: 
Option Explicit
Private Sub CommandButton1_Click()
Dim aktif_Ktp, SayfaAdi, Kayit_syf, i, k
Dim SonSatir
Dim SonSat
SonSat = Cells(Rows.Count,"A").End(xlUp).Row
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Sayfa1"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "2.xls"
SayfaAdi = "Sayfa1"
Workbooks.Open (dosya_yeri & dosya)

Workbooks(dosya).Sheets(SayfaAdi).Range("A3:A" & SonSatir).ClearContents 'Silmek için
For i = 3 To SonSat
    For k = 1 To 34
        SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1
        Workbooks(dosya).Sheets(SayfaAdi).Cells(SonSatir, k) = Workbooks(aktif_Ktp).Sheets("Sayfa1").Cells(i, k)
    Next k
Next i
Workbooks(dosya).Save
Workbooks(dosya).Close
MsgBox "Aktarma işlemi tamamlandı..." & Chr(10) & Chr(10) & "İyi çalışmalar...", vbInformation, "ASKM"
End Sub
[\Code]
 
Sabah kontrol eder tekrar atarım. +1 ifadesini silip deneyin.
 
Kodlar bu şekilde bende sıkıntısız çalışıyor.
Kod: 
Option Explicit
Private Sub CommandButton1_Click()
Dim aktif_Ktp, SayfaAdi, Kayit_syf, i, k
Dim SonSatir
Dim SonSat
Application.ScreenUpdating = False
Application.DisplayAlerts = False

SonSat = Range("A65536").End(xlUp).Row
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Sayfa1"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "2.xls"
SayfaAdi = "Sayfa1"
Workbooks.Open (dosya_yeri & dosya)
Workbooks(dosya).Sheets(SayfaAdi).Range("A3:AH65000").ClearContents 'Silmek için
For i = 3 To SonSat
SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1
    For k = 1 To 34
        Workbooks(dosya).Sheets(SayfaAdi).Cells(SonSatir, k) = Workbooks(aktif_Ktp).Sheets("Sayfa1").Cells(i, k)
    Next k
Next i
Workbooks(dosya).Save
Workbooks(dosya).Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Aktarma işlemi tamamlandı..." & Chr(10) & Chr(10) & "İyi çalışmalar...", vbInformation, "ASKM"
End Sub
 
günaydın çalıştı üstüne kayıt yapıyor yalnız 2.xls dosyasına atarken 3.satırdan başlaması gerekirken 2. satıra kopyalıyor kusura bakmayın yordum sizi
 
Kusura bakmayın. Kodu aşağıdaki gibi güncellerseniz olur sanırım.
Kod: 
Option Explicit
Private Sub CommandButton1_Click()
Dim aktif_Ktp, SayfaAdi, Kayit_syf, i, k
Dim SonSatir
Dim SonSat
Application.ScreenUpdating = False
Application.DisplayAlerts = False

SonSat = Range("A65536").End(xlUp).Row
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "Sayfa1"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "2.xls"
SayfaAdi = "Sayfa1"
Workbooks.Open (dosya_yeri & dosya)
Workbooks(dosya).Sheets(SayfaAdi).Range("A3:AH65000").ClearContents 'Silmek için
For i = 3 To SonSat
SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("B" & Rows.Count).End(xlUp).Row + 1
    For k = 1 To 34
        Workbooks(dosya).Sheets(SayfaAdi).Cells(SonSatir, k) = Workbooks(aktif_Ktp).Sheets("Sayfa1").Cells(i, k)
    Next k
Next i
Workbooks(dosya).Save
Workbooks(dosya).Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Aktarma işlemi tamamlandı..." & Chr(10) & Chr(10) & "İyi çalışmalar...", vbInformation, "ASKM"
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst