Verileri Otomatik İlgili Sayfaya Aktarma

[amigo1905]

Arkadaşlar daha önce sizin yardımlarınızla yarısına kadar düzenlemiş olduğum makromun bir yerinde takıldım.

Makro daki amaç ''KONSOL'' sayfasına yazılmış olan verileri ''AKTAR'' butonuna basıldığında ''B'' sütununda yazılı olan firma kodlarına göre ait olduğu sayfaya; ''D'' sütununda olan verileri stok kodlarına göre ait olduğu sayfaya otomatik olarak aktarması. Ama ben sadece S.001, S.002, ... diye devam eden firma kodlarına göre aktarılan makroyu düzenleyebildim. ''D'' sütununa göre verileri aktaracağı kodu yapamadım. ''AKTAR'' butonuna basıldığında iki işlemi aynı anda yapacak bir makro kodu arıyorum.

Örnek dosya ektedir.

Yardımlarınızı bekliyorum.

Şimdiden yardımlarınız için çok teşekkür ederim.

 

[amigo1905]

Arkadaşlar yardımlarınızı bekliyorum.

 

[quesh]

Kodunuzu aşağıdaki şekilde düzeltiniz.

Sub aktar()
Private Sub CommandButton1_Click()
Set s1 = ThisWorkbook.Worksheets("KONSOL")
'B sutunundaki kodları tarıyoruz
For i = 3 To s1.Rows.Count
If s1.Cells(i, 1) = "" Then Exit For ' ilk boş satırda döngüden çık..
Set s2 = ThisWorkbook.Worksheets(s1.Cells(i, 2).Value) ' firma kodu neyse onun sayfasına yönlendiriyoruz
sonsatir = s2.Range("A65536").End(xlUp).Row + 1
s2.Cells(sonsatir, 1) = Format(s1.Range("B1"), "dd.mm.yyyy") 'tarih
s2.Cells(sonsatir, 2) = s1.Cells(i, 1) 'tutanak no
s2.Cells(sonsatir, 3) = s1.Cells(i, 4) ' stok kodu
s2.Cells(sonsatir, 4) = s1.Cells(i, 5) ' fatura kodu
s2.Cells(sonsatir, 5) = s1.Cells(i, 6) ' stok adı
s2.Cells(sonsatir, 6) = s1.Cells(i, 7) ' renk
s2.Cells(sonsatir, 7) = s1.Cells(i, 8) ' boy
s2.Cells(sonsatir, 8) = s1.Cells(i, 9) ' mevcut adet
s2.Cells(sonsatir, 9) = s1.Cells(i, 10) ' birim
s2.Cells(sonsatir, 10) = s1.Cells(i, 11) ' mevcut kg
s2.Cells(sonsatir, 11) = s1.Cells(i, 12) ' birim
s2.Cells(sonsatir, 12) = s1.Cells(i, 13) ' birim fiyatı
s2.Cells(sonsatir, 13) = s1.Cells(i, 14) ' 1 mt ağırlığı
s2.Cells(sonsatir, 14) = s1.Cells(i, 15) ' bir boy ağırlığı
s2.Cells(sonsatir, 15) = s1.Cells(i, 16) ' toplam değeri
Set s2 = Nothing
Next i
Set y1 = ThisWorkbook.Worksheets("KONSOL")
For j = 3 To y1.Rows.Count
If y1.Cells(j, 1) = "" Then Exit For ' ilk boş satırda döngüden çık..
Set y2 = ThisWorkbook.Worksheets(y1.Cells(j, 2).Value) 'stok kodu neyse onun sayfasına yönlendiriyoruz
sonstr = y2.Range("A65536").End(xlUp).Row + 1
y2.Cells(sonstr, 1) = Format(y1.Range("B1"), "dd.mm.yyyy") 'tarih
y2.Cells(sonstr, 2) = y1.Cells(j, 1) 'tutanak no
y2.Cells(sonstr, 3) = y1.Cells(j, 2) ' firma kodu
y2.Cells(sonstr, 4) = y1.Cells(j, 3) ' firma ismi
y2.Cells(sonstr, 5) = y1.Cells(j, 7) ' renk
y2.Cells(sonstr, 6) = y1.Cells(j, 8) ' boy
y2.Cells(sonstr, 7) = y1.Cells(j, 9) ' mevcut adet
y2.Cells(sonstr, 8) = y1.Cells(j, 10) ' birim
y2.Cells(sonstr, 9) = y1.Cells(j, 11) ' mevcut kg
y2.Cells(sonstr, 10) = y1.Cells(j, 12) ' birim
y2.Cells(sonstr, 11) = y1.Cells(j, 13) ' birim fiyatı
y2.Cells(sonstr, 12) = y1.Cells(j, 14) ' 1 mt ağırlığı
y2.Cells(sonstr, 13) = y1.Cells(j, 15) ' bir boy ağırlığı
y2.Cells(sonstr, 14) = y1.Cells(j, 16) ' toplam değeri
Set y2 = Nothing
Next j
MsgBox "AKTARILDI"
End Sub

 

[amigo1905]

quest kodu denedim ama olmadı. verilerin hepsini S.001, S.002, .... sayfalara atıyor M.01.01.01.01, M.01.01.01.02 .... sayfalarına aktarmıyor direk S.001, S.002, .... sayfalarına aktarıyor. Tekrar bir bakabilir misin acaba...

 

[amigo1905]

guest şu şekilde düzeltince sanırım oluyor. Yine de yardımların için çok ama çok teşekkür ederim.

Sub aktar()
Private Sub CommandButton1_Click()
Set s1 = ThisWorkbook.Worksheets("KONSOL")
'B sutunundaki kodları tarıyoruz
For i = 3 To s1.Rows.Count
If s1.Cells(i, 1) = "" Then Exit For ' ilk boş satırda döngüden çık..
Set s2 = ThisWorkbook.Worksheets(s1.Cells(i, 2).Value) ' firma kodu neyse onun sayfasına yönlendiriyoruz
sonsatir = s2.Range("A65536").End(xlUp).Row + 1
s2.Cells(sonsatir, 1) = Format(s1.Range("B1"), "dd.mm.yyyy") 'tarih
s2.Cells(sonsatir, 2) = s1.Cells(i, 1) 'tutanak no
s2.Cells(sonsatir, 3) = s1.Cells(i, 4) ' stok kodu
s2.Cells(sonsatir, 4) = s1.Cells(i, 5) ' fatura kodu
s2.Cells(sonsatir, 5) = s1.Cells(i, 6) ' stok adı
s2.Cells(sonsatir, 6) = s1.Cells(i, 7) ' renk
s2.Cells(sonsatir, 7) = s1.Cells(i, 8) ' boy
s2.Cells(sonsatir, 8) = s1.Cells(i, 9) ' mevcut adet
s2.Cells(sonsatir, 9) = s1.Cells(i, 10) ' birim
s2.Cells(sonsatir, 10) = s1.Cells(i, 11) ' mevcut kg
s2.Cells(sonsatir, 11) = s1.Cells(i, 12) ' birim
s2.Cells(sonsatir, 12) = s1.Cells(i, 13) ' birim fiyatı
s2.Cells(sonsatir, 13) = s1.Cells(i, 14) ' 1 mt ağırlığı
s2.Cells(sonsatir, 14) = s1.Cells(i, 15) ' bir boy ağırlığı
s2.Cells(sonsatir, 15) = s1.Cells(i, 16) ' toplam değeri
Set s2 = Nothing

Set s3 = ThisWorkbook.Worksheets(s1.Cells(i, 4).Value)
sonsatir = s3.Range("A65536").End(xlUp).Row + 1
s3.Cells(sonsatir, 1) = Format(s1.Range("B1"), "dd.mm.yyyy") 'tarih
s3.Cells(sonsatir, 2) = s1.Cells(i, 1)
s3.Cells(sonsatir, 3) = s1.Cells(i, 2)
s3.Cells(sonsatir, 4) = s1.Cells(i, 3)
s3.Cells(sonsatir, 5) = s1.Cells(i, 7) 'renk
s3.Cells(sonsatir, 6) = s1.Cells(i, 8) ' boy
s3.Cells(sonsatir, 7) = s1.Cells(i, 9)
s3.Cells(sonsatir, 8) = s1.Cells(i, 10) ' mevcut adet
s3.Cells(sonsatir, 9) = s1.Cells(i, 11) ' birim
s3.Cells(sonsatir, 10) = s1.Cells(i, 12) ' mevcut kg
s3.Cells(sonsatir, 11) = s1.Cells(i, 13) ' birim
s3.Cells(sonsatir, 12) = s1.Cells(i, 14) ' birim fiyatı
s3.Cells(sonsatir, 13) = s1.Cells(i, 15) ' 1 mt ağırlığı
s3.Cells(sonsatir, 14) = s1.Cells(i, 16) ' bir boy ağırlığı
s3.Cells(sonsatir, 15) = s1.Cells(i, 17) ' toplam değeri
Set s3 = Nothing


Next i
MsgBox "AKTARILDI"
End Sub

 

[quesh]

dosyanızı tekrar ekliyorum . bende sorun vermeden ilgili sayfalara atıyor, tekrar bir deneyin verdiğim eki.