Satıra girilen verileri sütunlara kopyalama

[vein03051976]

Merhabalar

Ekteki dosyada "Tablo" sheetinde veriler mevcut

Bunları "Son hali" sheetindeki hale getirmek istiyoruz.

A sütununa İlgili mağazayı yazacak ve sadece onun modellerini ve adetlerini getirecek daha sonra diğer mağazayı aşağıya yerleştirecek sadece onun model ve adetlerini getirecek.

Böylece özet tablo haline getirebileceğiz.

İlginize şimdiden teşekkürler

Not: Tabloda görünenden daha az ve çok mağaza olabilmektedir. Tablo sağa doğru uzayabiliyor.

 

[DoğanD]

Merhaba,

Aşağıdaki kodları boş bir modüle ekleyip dener misiniz?

Sub Deneme()
Dim tabloSatir, Satir, Sutun As Integer
sayfa3.range("A3:S" & Sayfa3.Range("A" & Rows.Count).End(xlUp).Row+1).clearcontents
Satir = 3
    For Sutun = 16 To 160 Step 3
    For tabloSatir = 3 To Sayfa2.Range("A" & Rows.Count).End(xlUp).Row
        If Sayfa2.Cells(tabloSatir, Sutun) = "-" Then GoTo atla
        If Sayfa2.Cells(1, Sutun) = "" Then GoTo bitir
        
        Sayfa3.Cells(Satir, 1) = Sayfa2.Cells(1, Sutun)
        Sayfa3.Range("B" & Satir & ":P" & Satir).Value = Sayfa2.Range("A" & tabloSatir & ":O" & tabloSatir).Value
        Sayfa3.Range("q" & Satir & ":s" & Satir).Value = Sayfa2.Range(Sayfa2.Cells(tabloSatir, Sutun), Sayfa2.Cells(tabloSatir, Sutun + 2)).Value
Satir = Satir + 1
atla:
        Next tabloSatir
    Next Sutun
bitir:
    MsgBox "Tamamlandı!", vbInformation
End Sub

 

[vein03051976]

Merhaba

Run time hatası aldım. Gönderdiğim dosyaya ekleyip gönderme şansınız olur mu?

 

[DoğanD]

CTRL + q kombinasyonu ile makroyu çalıştırabilirsiniz.

 

[vein03051976]

Çok teşekkürler

Ellere sağlık

 

[vein03051976]

Merhabalar

Diğer Tabloda yaptığınız Kodu ekteki tabloya uygulamaya çalıştım ama beceremedim :-(

Aynı mantık ile bu tabloyu da yapabilir misiniz?

"Yapmak İstediğimiz" Sheetinde örnek var. Her mağazayı Alt alta eklemek istiyoruz.

 

[DoğanD]

Merhabalar

Diğer Tabloda yaptığınız Kodu ekteki tabloya uygulamaya çalıştım ama beceremedim :-(

Aynı mantık ile bu tabloyu da yapabilir misiniz?

"Yapmak İstediğimiz" Sheetinde örnek var. Her mağazayı Alt alta eklemek istiyoruz.

Merhaba,

Kodları aşağıdaki gibi revize ettim, kontrol eder misiniz?

Sub Deneme()
Dim tabloSatir, Satir, Sutun As Integer
Sayfa2.Range("A2:M" & Sayfa2.Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents
Satir = 2
    For Sutun = 11 To 160 Step 2
    For tabloSatir = 2 To Sayfa1.Range("A" & Rows.Count).End(xlUp).Row
        If Sayfa1.Cells(tabloSatir, Sutun) = 0 Then GoTo atla
        If Sayfa1.Cells(1, Sutun) = "" Then GoTo bitir
        
        Sayfa2.Cells(Satir, 1) = Sayfa1.Cells(1, Sutun)
        Sayfa2.Range("B" & Satir & ":K" & Satir).Value = Sayfa1.Range("A" & tabloSatir & ":j" & tabloSatir).Value
        Sayfa2.Range("L" & Satir & ":M" & Satir).Value = Sayfa1.Range(Sayfa1.Cells(tabloSatir, Sutun), Sayfa1.Cells(tabloSatir, Sutun + 1)).Value
Satir = Satir + 1
atla:
        Next tabloSatir
    Next Sutun
bitir:
    MsgBox "Tamamlandı!", vbInformation
End Sub