Soru Sütundaki Şube İsimlerini Alt Alta yazdırmak

[bulentkars]

Değerli Arkadaşlar Merhaba;

Ekteki Tabloda örnek ile anlattım yardımcı olabilirseniz sevinirim.
Şimdiden Teşekkürler.


Yapmak İstediğim;
Şube Kodları ve Şube İsimleri soldan sağa doğru yazılı,
ben şube kodlarını ve isimlerini ürün kodu ve adları kadar çoğaltarak alt alta yazdırmak istiyorum.

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Integer, b As Integer
Dim x As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Örnek Sonuç")
x = 2
s2.Range("A2:E" & s2.UsedRange.Rows.Count).ClearContents
For b = 3 To s1.Cells(1, Columns.Count).End(1).Column
    For a = 3 To s1.Cells(Rows.Count, "B").End(3).Row
        s2.Cells(x, 1) = s1.Cells(a, 1)
        s2.Cells(x, 2) = s1.Cells(a, 2)
        s2.Cells(x, 3) = s1.Cells(2, b)
        s2.Cells(x, 4) = s1.Cells(1, b)
        s2.Cells(x, 5) = s1.Cells(a, b)
        x = x + 1
    Next
Next
End Sub

 

[bulentkars]

Ömer Bey,
Elinize Emeğinize sağlık. Tam istediğim gibi olmuş,
Kopyalama işlemini Örnek sonuç sayfasına değilde
Yeni bir sayfa oluşturup işlemi yeni oluşturduğumuz sayfada yapabilir miyiz acaba.

 

[ÖmerBey]

Set s2 = Sheets("Örnek Sonuç")
Bu satırdaki "Örnek Sonuç" ifadesini istediğiniz sayfa ismiyle değiştirebilirsiniz.

 

[bulentkars]

Ömer Bey
Aynı dosyada değil
Yeni bir çalışma kitabı oluşturup kopyalama işlemini yeni çalışma kitabının sayfa1 inde yapmak istiyorum. Teşekkürler

 

[ÖmerBey]

Buyurunuz.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Integer, b As Integer
Dim x As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Workbooks.Add.Sheets(1)
s2.Cells(1, 1) = "Ürün Kodu"
s2.Cells(1, 2) = "Ürün Adı"
s2.Cells(1, 3) = "ŞUBE ADI"
s2.Cells(1, 4) = "DEPO KODU"
s2.Cells(1, 5) = "ADET"
s2.Range("A1:E1").Interior.ColorIndex = 6
x = 2
For b = 3 To s1.Cells(1, Columns.Count).End(1).Column
    For a = 3 To s1.Cells(Rows.Count, "B").End(3).Row
        s2.Cells(x, 1) = s1.Cells(a, 1)
        s2.Cells(x, 2) = s1.Cells(a, 2)
        s2.Cells(x, 3) = s1.Cells(2, b)
        s2.Cells(x, 4) = s1.Cells(1, b)
        s2.Cells(x, 5) = s1.Cells(a, b)
        x = x + 1
    Next
Next
s2.Columns("A:E").AutoFit
End Sub

 

[bulentkars]

Ömer Bey;
Elinize emeğinize sağlık. Çok Teşekkür ederim. Allah razı olsun

 

[ÖmerBey]

Rica ederim, Allah hepimizden razı olsun.
İyi çalışmalar...