Su makbuzu

[zfr10]

Selam arkadaşlar su makbuzu ile ilgili hazırladığım sayafanın makbuz sayfasında üç tane makbuz var fakat bu makbuzlara giriş sayfasındaki verileri otomatik olarak alıp sırasıyla üçer üçer yazdırmak istiyorum.Birde giriş sayfasındaki f5 ile f1000 arasındaki boş olan isimlerin makbuzlarını otomatik yazdırma sırasında yazdırılmamasını istiyorum.Yardımlarınızı bekliyorum.
Saygılar...

 

[halit3]

Selam arkadaşlar su makbuzu ile ilgili hazırladığım sayafanın makbuz sayfasında üç tane makbuz var fakat bu makbuzlara giriş sayfasındaki verileri otomatik olarak alıp sırasıyla üçer üçer yazdırmak istiyorum.Birde giriş sayfasındaki f5 ile f1000 arasındaki boş olan isimlerin makbuzlarını otomatik yazdırma sırasında yazdırılmamasını istiyorum.Yardımlarınızı bekliyorum.
Saygılar...

Bu kodu denermisiniz.

Sub aktar()
Dim sat
sat = 0
For r = 5 To Worksheets("GİRİŞ").Cells(Rows.Count, "B").End(3).Row
If Sheets("GİRİŞ").Cells(r, "f").Value > 0 Then
sat = sat + 1
If sat = 1 Then
Sheets("MAKBUZ").Cells(2, "f").Value = Sheets("GİRİŞ").Cells(r, "b").Value
Sheets("MAKBUZ").Cells(3, "f").Value = Sheets("GİRİŞ").Cells(r, "a").Value
Sheets("MAKBUZ").Cells(4, "f").Value = Sheets("GİRİŞ").Cells(r, "c").Value
Sheets("MAKBUZ").Cells(7, "a").Value = Sheets("GİRİŞ").Cells(r, "d").Value
Sheets("MAKBUZ").Cells(7, "b").Value = Sheets("GİRİŞ").Cells(r, "e").Value
Sheets("MAKBUZ").Cells(9, "c").Value = Sheets("GİRİŞ").Cells(r, "f").Value
End If
If sat = 2 Then
Sheets("MAKBUZ").Cells(13, "f").Value = Sheets("GİRİŞ").Cells(r, "b").Value
Sheets("MAKBUZ").Cells(14, "f").Value = Sheets("GİRİŞ").Cells(r, "a").Value
Sheets("MAKBUZ").Cells(15, "f").Value = Sheets("GİRİŞ").Cells(r, "c").Value
Sheets("MAKBUZ").Cells(18, "a").Value = Sheets("GİRİŞ").Cells(r, "d").Value
Sheets("MAKBUZ").Cells(18, "b").Value = Sheets("GİRİŞ").Cells(r, "e").Value
Sheets("MAKBUZ").Cells(20, "c").Value = Sheets("GİRİŞ").Cells(r, "f").Value
End If
If sat = 3 Then
Sheets("MAKBUZ").Cells(24, "f").Value = Sheets("GİRİŞ").Cells(r, "b").Value
Sheets("MAKBUZ").Cells(25, "f").Value = Sheets("GİRİŞ").Cells(r, "a").Value
Sheets("MAKBUZ").Cells(26, "f").Value = Sheets("GİRİŞ").Cells(r, "c").Value
Sheets("MAKBUZ").Cells(29, "a").Value = Sheets("GİRİŞ").Cells(r, "d").Value
Sheets("MAKBUZ").Cells(29, "b").Value = Sheets("GİRİŞ").Cells(r, "e").Value
Sheets("MAKBUZ").Cells(31, "c").Value = Sheets("GİRİŞ").Cells(r, "f").Value
Sheets("MAKBUZ").PageSetup.PrintArea = "$A$1:$H$33"
Sheets("MAKBUZ").PrintOut Copies:=1, Collate:=True
sat = 0
End If
End If
Next r
If sat <> 3 Then
If sat = 1 Then
Sheets("MAKBUZ").PageSetup.PrintArea = "$A$1:$H$11"
Sheets("MAKBUZ").PrintOut Copies:=1, Collate:=True
End If
If sat = 2 Then
Sheets("MAKBUZ").PageSetup.PrintArea = "$A$1:$H$22"
Sheets("MAKBUZ").PrintOut Copies:=1, Collate:=True
End If
End If

End Sub

 

[zfr10]

Çok teşekkür ediyorum Halit Bey emeğinize sağlık saygılarımı sunuyorum.

 

[halit3]

Çok teşekkür ediyorum Halit Bey emeğinize sağlık saygılarımı sunuyorum.

2 nolu mesajdaki dosya işyerindeki bilgisayarda çalışıyordu ama evdeki bilgisayrada denediğimde küçük bir hata vardı ve denemek için kodu ilk yazdırmada durdurmuştum şimdi kodda küçük düzenlemeler yaptım.

 

[mhaluksen]

yeni kodu bir daha verebilir misiniz?

 

[halit3]

yeni kodu bir daha verebilir misiniz?

Kod 2 nolu mesajda güncellenmiştir.