Makro ile tablo doldurmak

[muhendis1755]

Merhaba,

Benim bir tablom var ön sayfada ki verileri arkada ki tablo ya makro ile aktarmak istiyorum.Yardımlarınızı bekliyorum.

 

[askm]

Sanırım çıktı almak için istiyorsunuz.

Sub askm()
Dim SonSat As Integer
Dim Satir, Stn As Integer
SonSat = Sheets("Sayfa3").Range("A" & Rows.Count).End(xlUp).Row
Satir = 3
For i = 2 To SonSat
Stn = 1
    For x = 1 To 2
        Sheets("Sayfa1").Cells(Satir, Stn) = Sheets("Sayfa3").Cells(i, 1)
        Sheets("Sayfa1").Cells(Satir - 1, Stn + 3) = Sheets("Sayfa3").Cells(i, 4)
        Sheets("Sayfa1").Cells(Satir, Stn + 3) = Sheets("Sayfa3").Cells(i, 2)
        Sheets("Sayfa1").Cells(Satir + 1, Stn + 3) = Sheets("Sayfa3").Cells(i, 3)
        Sheets("Sayfa1").Cells(Satir + 2, Stn + 3) = Sheets("Sayfa3").Cells(i, 5)
        Stn = Stn + 5
    Next x
    If Satir > 19 Then
        Satir = 3
        Sheets("Sayfa1").PrintPreview
    Else
        Satir = Satir + 4
    End If
Next i
Sheets("Sayfa1").PrintPreview
MsgBox "İşlem Tamamlandı...", vbInformation, "ASKM"
End Sub

 

[muhendis1755]

Mükemmel olmuş fakat sorun şu her etiketten 2 adet değil 1 adet olması gerekiyor.Yani öndeki 10 adet veri etiket sayfasında ki 10 adet etikete aktarmak istiyorum. Bunu da excel içerisinde ki bir butona bağlamak istiyorum.

 

[askm]

Sayfaya bir buton yada resim ekleyerek. Makro ata deyip askm seçtiğinizde butona atamış olursunuz.
Aşağıdaki şekilde deneyin.

Sub askm()
Dim SonSat As Integer
Dim Satir, Stn As Integer
SonSat = Sheets("Sayfa3").Range("A" & Rows.Count).End(xlUp).Row
Satir = 3
For i = 2 To SonSat
Stn = 1
    For x = 1 To 2
        Sheets("Sayfa1").Cells(Satir, Stn) = Sheets("Sayfa3").Cells(i, 1)
        Sheets("Sayfa1").Cells(Satir - 1, Stn + 3) = Sheets("Sayfa3").Cells(i, 4)
        Sheets("Sayfa1").Cells(Satir, Stn + 3) = Sheets("Sayfa3").Cells(i, 2)
        Sheets("Sayfa1").Cells(Satir + 1, Stn + 3) = Sheets("Sayfa3").Cells(i, 3)
        Sheets("Sayfa1").Cells(Satir + 2, Stn + 3) = Sheets("Sayfa3").Cells(i, 5)
        Stn = Stn + 5
        i = i + 1
    Next x
    If Satir > 19 Then
        Satir = 3
        Sheets("Sayfa1").PrintPreview
    Else
        Satir = Satir + 4
    End If
Next i
Sheets("Sayfa1").PrintPreview
MsgBox "İşlem Tamamlandı...", vbInformation, "ASKM"
End Sub

 

[muhendis1755]

Öncelikle ellerinize sağlık , kodu denedim , son 3 kutucuk da kayma oluyor ve ikinci bir sayfaya atlıyor. Yani aradaki bazı verileri almayıp aşağıya kaydırıyor. 10 adet verinin 10 adet etikete oturması lazım.

 

[askm]

next i ifadesinden önce i=i-1 yazarsanız düzelir. Bende şimdi kontrol ettim farkettim.

 

[muhendis1755]

Çok teşekkür ederim.

 

[askm]

Rica ederim.

 

[muhendis1755]

Çalışmayı bu hale getirdim sayenizde fakat son bir şey, son iki etiket de logo çıkmıyor. Kod da son bir şey eksik kaldı galiba.

 

[askm]

Çıktı aldığınızda logo çıkıyor. Preview (Önizleme) kısmında küçük olduğu için görünmüyor.
Sheets("Sayfa1").PrintPreview kısımlarını Sheets("Sayfa1").Printout olarak değiştirirseniz direkt çıktı alabilirsiniz. Ben kağıt harcamamak için önizleme yapmıştım.

 

[muhendis1755]

Çok teşekkür ederim.

 

[askm]

Rica ederim.