Kolon , Satır ve kesişen verileri satıra dönüştürmek

[yda64]

Herkese merhaba,
Ekteki dosyada,
Datalarını her seferinde başka bir dosyadan kopyala yapıştır yaptığım SIPARIS sayfası var.
Bu sayfada kolon ve satır sayıları değişebiliyor. Her kolonun son satırında da Siparis numarası bulunuyor. SIPARIS sayfasına baglı olarak DATA sayfasındaki satırları yaratmamız gerekiyor
Konu ile ilgili arkadaşların yardımları için şimdiden teşekkürler

 

[Ömer]

Merhaba,

Bu şekilde deneyiniz..

Sub Aktar()
 
Dim Ss As Worksheet, Sd As Worksheet, sut As Integer
Dim sat As Long, satd As Long, saty As Long, i As Integer
 
Set Ss = Sheets("Siparis")
Set Sd = Sheets("Data")
sat = Ss.Cells(Rows.Count, "A").End(xlUp).Row
sut = Ss.Cells(1, Columns.Count).End(xlToLeft).Column
 
Application.ScreenUpdating = False
Sd.Range("A2:D" & Rows.Count).ClearContents
 
For i = 2 To sut
    satd = Sd.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ss.Range("A2:A" & sat - 1).Copy Sd.Range("A" & satd)
    saty = Sd.Cells(Rows.Count, "A").End(xlUp).Row
    Ss.Cells(1, i).Copy Sd.Range(Sd.Cells(satd, "B"), Sd.Cells(saty, "B"))
    Ss.Range(Ss.Cells(2, i), Ss.Cells(sat - 1, i)).Copy Sd.Range("C" & satd)
    Ss.Cells(sat, i).Copy Sd.Range(Sd.Cells(satd, "D"), Sd.Cells(saty, "D"))
Next i
 
Application.ScreenUpdating = True
 
End Sub

.

 

[yda64]

Çok teşekkürler
Tam istediğim gibi çalışıyor.
İleride ekteki dosya gibi bir ekleme yapmak istersek kodu nasıl düzeltmemiz gerektiğini de yardımcı olabilirseniz çok sevinirim.
Data Sayfasında Adet Kolonunda 0 (Sıfır) olan satırları filtreleyip listede görünmemesini sağlayabiliyorum ancak kod çalışma esnasında 0 olan satırları listeye getirmese çok şey istemiş olurmuyum ?

Şimdiden teşekkürler.

 

[Ömer]

Bu şekilde deneyiniz.

Sub Aktar()
 
Dim Ss As Worksheet, sut As Integer, j As Long
Dim sat As Long, satd As Long, saty As Long, i As Integer
 
Set Ss = Sheets("Siparis")
Sheets("Data").Select
sat = Ss.Cells(Rows.Count, "A").End(xlUp).Row
sut = Ss.Cells(1, Columns.Count).End(xlToLeft).Column
 
Application.ScreenUpdating = False
Range("A2:E" & Rows.Count).ClearContents
 
For i = 2 To sut - 1
    satd = Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ss.Range("A2:A" & sat - 1).Copy Range("A" & satd)
    Ss.Range("B2:B" & sat - 1).Copy Range("B" & satd)
    saty = Cells(Rows.Count, "A").End(xlUp).Row
    Ss.Cells(1, i + 1).Copy Range(Cells(satd, "C"), Cells(saty, "C"))
    Ss.Range(Ss.Cells(2, i + 1), Ss.Cells(sat - 1, i + 1)).Copy Range("D" & satd)
    Ss.Cells(sat, i + 1).Copy Range(Cells(satd, "E"), Cells(saty, "E"))
Next i
 
For j = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
    If Cells(j, "D") = 0 Then
        Rows(j).Delete
    End If
Next j
 
Application.ScreenUpdating = True
 
End Sub

.

 

[yda64]

İşlem tamam düzgün çalışıyor
Yardımlarınız için teşekkürler