İsimlerin yazdırılması

[mid-bim]

Ýsimlerin yazdırılması

Merhaba arkadaşlar sizden bir isteğim olcak Benim istediğim ekte göndereceğim excel sayfasında
data sayfasında bulunan isimler var her isimden farklı sayıda değişiyor bazen aynı isim 5 bazen 12
tane olabiliyor benim isteğim bu isimleri basım sayfasındaki ayarlanmış olan alana yerleştirilmesi
ve her isim değiştikçe tekrar basım sayfasına aktarılıp yazıcıdan çıktısı alınması önemli olan ayını
isimle basılacak ve yanıdaki numaralar la beraber yardımız için şimdiden tşk. ediyorum. :dua: :hey:

 

[Exelans]

Aşağıdaki kodları DATA sayfansının kod sayfasına aynen yapıştır.
[vb:1:36c29386c2]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
a = ActiveCell.Row

If Cells(a, 5) = "" Or Cells(a - 1, 5) = Cells(a, 5) Then Exit Sub
For b = 20 To 31
Worksheets("Basım").Rows(b).ClearContents
Next b

For k = 2 To a - 1
If Cells(k, 5) = Cells(a - 1, 5) Then Exit For
Next k
c = 20
For y = k To a - 1
For x = 1 To 8
Worksheets("Basım").Cells(c, x + 1) = Cells(y, x)
Next x
c = c + 1
Next y
Worksheets("Basım").PrintOut Copies:=1
End Sub[/vb:1:36c29386c2]

 

[mid-bim]

Tşk. Exelans ama çalışmıyor yolladığınız kod işimi göremedim ilgilendiğinz için tşk. :hey:

 

[Necdet]

wordteki mail merge (adres mektup birleştirme) bu olaya tam uyar. Excel dışında bir önerim oldu

 

[Levent Menteşoğlu]

Birde aşağıdaki kodu deneyin.

[vb:1:ee6b73b850]Sub aktar()
Set s1 = Sheets("Data")
Set s2 = Sheets("Basım")
s2.[b20:i31].ClearContents
For a = 2 To s1.Cells(65536, 1).End(xlUp).Row
If s2.[b20] = 0 Then GoTo 10
If s1.Cells(a, 5) <> s1.Cells(a - 1, 5) Then
s2.[b19:i31].PrintOut Copies:=1
s2.[b20:i31].ClearContents
c = 0
End If
10 c = c + 1
For b = 2 To 9
s2.Cells(c + 19, b) = s1.Cells(a, b - 1).Value
Next
Next
End Sub[/vb:1:ee6b73b850]

 

[mid-bim]

Sn leventm bey sizin verdiğiniz kod hata veriyor çalıştıramadım (s2.[b20:i31].ClearContents) diye bir hata çözemedim meseleyi tşk.

 

[Levent Menteşoğlu]

Ekteki örneği inceleyin.

 

[mid-bim]

Sn leventm bey kusura bakmayın ama yine çalışmıyor sizin gönderdiğiniz ekte Run-time error '424': diye hata veriyor. sizide uğraştırıyorum ama örnek çalışmıyor :kafa:

 

[Levent Menteşoğlu]

Ben kodları deneyerek verdim. Yalnız şu olabilir kodlar hızlı çalıştığından ve hepsini peşpeşe yazıcıya gönderdiğinden sorun çıkmış olabilir. bu durumda araya bir zamanlayıcı satır ilave edelim. Aşağıdaki kodu deneyin.

[vb:1:3e74e34978]Sub aktar()
Set s1 = Sheets("Data")
Set s2 = Sheets("Basım")
s2.[b20:i31].ClearContents
For a = 2 To s1.Cells(65536, 1).End(xlUp).Row
If s2.[b20] = 0 Then GoTo 10
If s1.Cells(a, 5) <> s1.Cells(a - 1, 5) Then
Application.Wait Now + TimeValue("00:00:02")
s2.[b19:i31].PrintOut Copies:=1
s2.[b20:i31].ClearContents
c = 0
End If
10 c = c + 1
For b = 2 To 9
s2.Cells(c + 19, b) = s1.Cells(a, b - 1).Value
Next
Next
End Sub [/vb:1:3e74e34978]