Bir sayfadaki aynı kayıtı diğer sayfada birden fazla satıra kaydetmek

[bilgemman]

Merhaba benim aşağıdaki gibi kodlarım var bu kodlarla 1.sayfadan 2.sayfaya verileri kaydedebiliyorum.Bunda sıkıntı yok.Benim yapmak istediğim Üretim verileri(Boy,çap,kalınlık,dakika,üretim,fire) gibi alanlar bir kaç satırdan oluşuyor bu kayıtları aktarırken personel no ,makine no gibi alanlarıda üretim verilerindeki satır kadar aktarmasını istiyorum ancak sadece bir satıra yazıyor.
Örnek;
Girilen veriler
Pers.No:100 Mak.No:5 Tarih : 30.11.2017
Dakika:20 Çap:12 Kalınlık:1,5 boy:900 hammadde boyu:5000 üretim:5000 Fire:0
Dakika:20 Çap:12 Kalınlık:1,5 boy:814 hammadde boyu:4500 üretim:1000 Fire:0
Kaydet dediğimde diğer sayfada çıkan sonuç
Sn:1 Pers.No:100 Mak.No:5 Tarih : 30.11.2017 Dk:20 Çap:12 Klnlk:1,5 Boy:900 Hamboy:5000 Üretim : 5000 Fire:0
Dk:20 Çap:14 Klnlk:1,5 Boy:814 Hamboy:4500 Üretim : 1000 Fire:0

Benim istediğimde ise

Sn:1 Pers.No:100 Mak.No:5 Tarih : 30.11.2017 Dk:20 Çap:12 Klnlk:1,5 Boy:900 Hamboy:5000 Üretim : 5000 Fire:0
Pers.No:100 Mak.No:5 Tarih : 30.11.2017 Dk:20 Çap:14 Klnlk:1,5 Boy:814 Hamboy:4500 Üretim : 1000 Fire:0

şeklinde kaydetmesi.Şimdiden Teşekkürler.




Dim g As Worksheet
Dim rd As Worksheet

Set g = Sheets("Üretim Formu")
Set rd = Sheets("Rapor")

Dim say As Long
say = rd.Cells(65536, 5).End(xlUp).Row + 1
ONBİR = WorksheetFunction.CountA(rd.Range("A2:A65536")) + 1
'Sıra No
rd.Range("A" & say).Offset = ONBİR
'Personel No
rd.Range("b" & say).Offset = g.Range("C2")
'Makine No
rd.Range("c" & say).Offset = g.Range("E2")
'Tarih
rd.Range("d" & say).Offset = g.Range("J2")


Dim alan As Range

For d = 1 To 5

'Dakika
g.Activate
Set alan = g.Range(g.Cells(5, "D"), g.Cells(14, "D")).SpecialCells(xlCellTypeConstants)
alan.Select
Selection.Copy
rd.Activate
rd.Cells(say, "I").PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Çap
g.Activate
Set alan = g.Range(g.Cells(5, "E"), g.Cells(14, "E")).SpecialCells(xlCellTypeConstants)
alan.Select
Selection.Copy
rd.Activate
rd.Cells(say, "E").PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Kalınlık
g.Activate
Set alan = g.Range(g.Cells(5, "F"), g.Cells(14, "F")).SpecialCells(xlCellTypeConstants)
alan.Select
Selection.Copy
rd.Activate
rd.Cells(say, "F").PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Boy
g.Activate
Set alan = g.Range(g.Cells(5, "G"), g.Cells(14, "G")).SpecialCells(xlCellTypeConstants)
alan.Select
Selection.Copy
rd.Activate
rd.Cells(say, "G").PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Hammadde
g.Activate
Set alan = g.Range(g.Cells(5, "H"), g.Cells(14, "H")).SpecialCells(xlCellTypeConstants)
alan.Select
Selection.Copy
rd.Activate
rd.Cells(say, "H").PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Adet
g.Activate
Set alan = g.Range(g.Cells(5, "I"), g.Cells(14, "I")).SpecialCells(xlCellTypeConstants)
alan.Select
Selection.Copy
rd.Activate
rd.Cells(say, "J").PasteSpecial xlPasteValues
Application.CutCopyMode = False

'Fire
g.Activate
Set alan = g.Range(g.Cells(5, "J"), g.Cells(14, "J")).SpecialCells(xlCellTypeConstants)
alan.Select
Selection.Copy
rd.Activate
rd.Cells(say, "K").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next d


MsgBox "Bilgiler kaydedildi", vbInformation, "KAYIT"

 

[cems]

Öncelikle foruma hoş geldiniz

Siteye ekleyemeseniz de , www.dosya.tc gibi bir dış servera bu dosyayı veya size göre örneğini zipleyerek yükler ve burada linkini verirseniz üzerinde çalışılıp denenecek , isteğinize uyunca da aynı yolla geri gönderebilecek bir zemin vermiş olursunuz.

 

[bilgemman]

Dosyanın linki ektedir.

http://s4.dosya.tc/server5/gwqapc/Uretim_Formu.rar.html