• DİKKAT

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

Veri aktarımı makro yardım

A

acetinnster

Katılım
15 Ocak 2013
Mesajlar
85
Excel Vers. ve Dili
2007 türkçe
Arkadaşlar aşağıdaki kodlar da yardımcı olabilirmisiniz nasıl bir döngü yapılması gerekmektedir.

Private Sub CommandButton1_Click()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "PROFORMA"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "SİPARİŞLER.xlsm"
SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks(dosya).Sheets(SayfaAdi).Range("A" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ6")
Workbooks(dosya).Sheets(SayfaAdi).Range("J" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ7")
Workbooks(dosya).Sheets(SayfaAdi).Range("S" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("B10")
Workbooks(dosya).Sheets(SayfaAdi).Range("AD" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("BF46")
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "PROFORMA"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "SİPARİŞLER.xlsm"
SayfaAdi = "MAMUL SEVK"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks(dosya).Sheets(SayfaAdi).Range("A" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ6")
Workbooks(dosya).Sheets(SayfaAdi).Range("G" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ7")
Workbooks(dosya).Sheets(SayfaAdi).Range("M" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("B10")

'Bu satırdan sonra eğer hücre dolu ise +1 nasıl ekleyebiliriz tüm satırlara Örnek = Range("B15")

Workbooks(dosya).Sheets(SayfaAdi).Range("S" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("B14")
Workbooks(dosya).Sheets(SayfaAdi).Range("Y" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("H14")
Workbooks(dosya).Sheets(SayfaAdi).Range("AE" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("N14")
Workbooks(dosya).Sheets(SayfaAdi).Range("AO" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("X14")
Workbooks(dosya).Sheets(SayfaAdi).Range("AT" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AC14")
Workbooks(dosya).Sheets(SayfaAdi).Range("AZ" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AI14")
Workbooks(dosya).Sheets(SayfaAdi).Range("BF" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AO14")
Workbooks(dosya).Sheets(SayfaAdi).Range("BO" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AX14")
Workbooks(dosya).Sheets(SayfaAdi).Range("BR" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("BA14")
Workbooks(dosya).Sheets(SayfaAdi).Range("BW" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("BF14")
Workbooks(dosya).Save
Workbooks(dosya).Close
End Sub
 
Merhaba
Kodlardaki ilgili bölümü aşağıdaki gibi değiştirerek deneyelim;
Kod: 
[SIZE="2"]
Private Sub CommandButton1_Click()
'....
'......
'.......kodlarınız
[COLOR="Blue"]
'Bu satırdan sonra eğer hücre dolu ise +1 nasıl ekleyebiliriz tüm satırlara Örnek = Range("B15")[/COLOR]

Set sy = Workbooks(dosya).Sheets(SayfaAdi)
Set sy1 = Workbooks(aktif_Ktp).Sheets("PROFORMA")

For x = 14 To sy1.Cells(Rows.Count, "B").End(3).Row
sy.Range("S" & SonSatir) = sy1.Range("B" & x)
sy.Range("Y" & SonSatir) = sy1.Range("H" & x)
sy.Range("AE" & SonSatir) = sy1.Range("N" & x)
sy.Range("AO" & SonSatir) = sy1.Range("X" & x)
sy.Range("AT" & SonSatir) = sy1.Range("AC" & x)
sy.Range("AZ" & SonSatir) = sy1.Range("AI" & x)
sy.Range("BF" & SonSatir) = sy1.Range("AO" & x)
sy.Range("BO" & SonSatir) = sy1.Range("AX" & x)
sy.Range("BR" & SonSatir) = sy1.Range("BA" & x)
sy.Range("BW" & SonSatir) = sy1.Range("BF" & x)
SonSatir = SonSatir + 1
Next
Workbooks(dosya).Save
Workbooks(dosya).Close
End Sub [/SIZE]
 
acetinnster' Alıntı:
Sayın Plint teşekkürler ancak derleme hatası vermekte
Genişletmek için tıkla ...
Örnek dosya olmadan zor görünüyor ama kodlarda kapalı dosya 2 kere açılmaya çalışılıyor kodları aşağıdaki gibi deneyelim
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "PROFORMA"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "SİPARİŞLER.xlsm"
SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks(dosya).Sheets(SayfaAdi).Range("A" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ6 ")
Workbooks(dosya).Sheets(SayfaAdi).Range("J" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ7 ")
Workbooks(dosya).Sheets(SayfaAdi).Range("S" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("B10 ")
Workbooks(dosya).Sheets(SayfaAdi).Range("AD" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("BF4 6")

SayfaAdi = "MAMUL SEVK"

SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks(dosya).Sheets(SayfaAdi).Range("A" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ6 ")
Workbooks(dosya).Sheets(SayfaAdi).Range("G" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ7 ")
Workbooks(dosya).Sheets(SayfaAdi).Range("M" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("B10 ")

Set sy = Workbooks(dosya).Sheets(SayfaAdi)
Set sy1 = Workbooks(aktif_Ktp).Sheets("PROFORMA")

For x = 14 To sy1.Cells(Rows.Count, "B").End(3).Row
sy.Range("S" & SonSatir) = sy1.Range("B" & x)
sy.Range("Y" & SonSatir) = sy1.Range("H" & x)
sy.Range("AE" & SonSatir) = sy1.Range("N" & x)
sy.Range("AO" & SonSatir) = sy1.Range("X" & x)
sy.Range("AT" & SonSatir) = sy1.Range("AC" & x)
sy.Range("AZ" & SonSatir) = sy1.Range("AI" & x)
sy.Range("BF" & SonSatir) = sy1.Range("AO" & x)
sy.Range("BO" & SonSatir) = sy1.Range("AX" & x)
sy.Range("BR" & SonSatir) = sy1.Range("BA" & x)
sy.Range("BW" & SonSatir) = sy1.Range("BF" & x)
SonSatir = SonSatir + 1
Next

Workbooks(dosya).Save
Workbooks(dosya).Close
End Sub
 [/SIZE]
 
Plit üstadın kodlarına ufak bir müdahele yaptım. İstediğiniz bu şekilde mi?
Kod: 
Private Sub CommandButton1_Click()
Dim aktif_Ktp, SayfaAdi, Kayit_syf
Dim SonSatir
Dim dosya_yeri, dosya
aktif_Ktp = ThisWorkbook.Name
Kayit_syf = "PROFORMA"
dosya_yeri = ThisWorkbook.Path & "\"
dosya = "SİPARİŞLER.xlsm"
SayfaAdi = "AÇIK SİPARİŞLER"
Workbooks.Open (dosya_yeri & dosya)
SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks(dosya).Sheets(SayfaAdi).Range("A" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ6")
Workbooks(dosya).Sheets(SayfaAdi).Range("J" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ7")
Workbooks(dosya).Sheets(SayfaAdi).Range("S" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("B10")
Workbooks(dosya).Sheets(SayfaAdi).Range("AD" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("BF46")

SayfaAdi = "MAMUL SEVK"

SonSatir = Workbooks(dosya).Sheets(SayfaAdi).Range("A" & Rows.Count).End(xlUp).Row + 1

Set sy = Workbooks(dosya).Sheets(SayfaAdi)
Set sy1 = Workbooks(aktif_Ktp).Sheets("PROFORMA")

For X = 14 To sy1.Cells(Rows.Count, "B").End(3).Row
sy.Range("A" & SonSatir) = Format(Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ6"), "dd.mm.yyyy")
sy.Range("G" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("AZ7")
sy.Range("M" & SonSatir) = Workbooks(aktif_Ktp).Sheets("PROFORMA").Range("B10")

sy.Range("S" & SonSatir) = sy1.Range("B" & X)
sy.Range("Y" & SonSatir) = sy1.Range("H" & X)
sy.Range("AE" & SonSatir) = sy1.Range("N" & X)
sy.Range("AO" & SonSatir) = sy1.Range("X" & X)
sy.Range("AT" & SonSatir) = sy1.Range("AC" & X)
sy.Range("AZ" & SonSatir) = sy1.Range("AI" & X)
sy.Range("BF" & SonSatir) = sy1.Range("AO" & X)
sy.Range("BO" & SonSatir) = sy1.Range("AX" & X)
sy.Range("BR" & SonSatir) = sy1.Range("BA" & X)
sy.Range("BW" & SonSatir) = sy1.Range("BF" & X)
SonSatir = SonSatir + 1
Next

Workbooks(dosya).Save
Workbooks(dosya).Close
End Sub
 
Sayın askm hocam tekrar tekrar teşekkürler ilgilendiğiniz için
Ancak eklemiş olduğum dosyaları inceleme fırsatınız var ise daha iyi anlayacaksınız vermiş olduğunuz kodlar da döngü fazla aldı başını gidiyor desem yeri var :)
 
Döngüden kastınızı anlamadım. Yalnız gördüğüm tek döngüsel fazlalık
For X = 14 To sy1.Cells(Rows.Count, "B").End(3).Row kısmı
B sütununda formül olduğu için 45 e kadar gidiyor. Ama aşağıdaki gibi olursa 30 da bitiyor.
For X = 14 To sy1.Cells(Rows.Count, "H").End(3).Row kısmı
 
Hocam affınıza sığınarak görseldeki gibi fazla veri demek istedim
 

Ekli dosyalar

  • aktarım.jpg
    aktarım.jpg
    254.2 KB · Görüntüleme: 9
Dosyanızı buraya yükleyebilir misiniz. (Özelden yazmıştım)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst