Sütundaki Herbir Kod İçin Alt Alta Tekrar Eden Bilgileri, Sütunlara Yan Yana Aktarmak

[bilal5412]

Merhaba arkadaşlar,

Ekteki bağlantıdaki dosyada bulunan örnek çalışmada Sayfa2 deki bilgileri Sayfa1 deki gibi düzenlemek istiyorum. Bu konuda yardımlarınızı rica ederim.

Kısaca yapılmak istenen,

Sayfa1deki A sütunundaki "kodlar" tarafımından doldurulacak olup bu kodlara karşılık gelen Sayfa2deki bilgileri aktarmak.

Sayfa2 deki A sütunundaki her bir koda karşılık gelen "kalan miktar,sip tarihi ve sip teslim" bilgilerini Sayfa1 deki gibi düzenlemek. Sayfa1deki düzen oluştururken Sayfa2deki herbir kodun en eski tarihinden itibaren başlayacaktır.

**Bilgi: Sayfa1 ve sayfa2 deki satır sayıları belirsizdir ve her iki sayfadaki A sütunlarında boş olan hücre yoktur. Sayfa2 de A sütununda bir kod karşılık birden fazla sipariş tarihi olabilir.

Yardımlarınız için şimdiden teşekkürler. Saygılar.




https://drive.google.com/file/d/0B3wJKQcxKCV4M1VQV2E3NklDamM/view?usp=sharing

 

[veyselemre]

Sub aktar()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    son = Cells(Rows.Count, 1).End(3).Row
    Range("B2", Cells(son, Columns.Count)).ClearContents

    For i = 2 To son
        For ii = 2 To s2.Cells(Rows.Count, 1).End(3).Row
            If s1.Cells(i, 1) = s2.Cells(ii, 1) Then
                Set huc = Cells(i, Columns.Count).End(xlToLeft).Offset(, 1)
                huc.Resize(1, 3).Value = s2.Cells(ii, 2).Resize(1, 3).Value
            End If
        Next ii
    Next i
    Set s1 = Nothing
    Set s2 = Nothing
End Sub

 

[bilal5412]

Sub aktar()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    son = Cells(Rows.Count, 1).End(3).Row
    Range("B2", Cells(son, Columns.Count)).ClearContents

    For i = 2 To son
        For ii = 2 To s2.Cells(Rows.Count, 1).End(3).Row
            If s1.Cells(i, 1) = s2.Cells(ii, 1) Then
                Set huc = Cells(i, Columns.Count).End(xlToLeft).Offset(, 1)
                huc.Resize(1, 3).Value = s2.Cells(ii, 2).Resize(1, 3).Value
            End If
        Next ii
    Next i
    Set s1 = Nothing
    Set s2 = Nothing
End Sub

Veysel bey merhaba, yardımlarınız için çok teşekkür ederim. Yazmış olduğunuz kod sorunumu çözdü.. Yazılan makroyu ben kendi dosyama entegre etmeyi denedim ama başarılı olamadım. Bu konuda yardımcı olabilir misiniz.

Ekte yeni bir bağlantı var. Bağlantıdaki dosyada bulunan formata uygun nasıl düzenleyebiliriz. Sadece sütun yerleri farklıdır ve Sayfa2 de bir sütunda daha vardı onu eklemeyi unutmuşum bu sütun E sütunudur.

https://drive.google.com/file/d/0B3wJKQcxKCV4X2taaUlSRGhpbFU/view?usp=sharing

 

[veyselemre]

Sub aktar()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    son = Cells(Rows.Count, 4).End(3).Row
    Range("M2", Cells(son, Columns.Count)).ClearContents
    For i = 2 To son
        For ii = 2 To s2.Cells(Rows.Count, 1).End(3).Row
            If s1.Cells(i, 4) = s2.Cells(ii, 1) Then
                For iii = 13 To Columns.Count Step 4
                    If Cells(i, iii) = "" Then
                        Cells(i, iii).Resize(1, 4).Value = s2.Cells(ii, 2).Resize(1, 4).Value
                        Exit For
                    End If
                Next iii
            End If
        Next ii
    Next i
    Set s1 = Nothing
    Set s2 = Nothing
End Sub

 

[bilal5412]

Sub aktar()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s1.Select
    son = Cells(Rows.Count, 4).End(3).Row
    Range("M2", Cells(son, Columns.Count)).ClearContents
    For i = 2 To son
        For ii = 2 To s2.Cells(Rows.Count, 1).End(3).Row
            If s1.Cells(i, 4) = s2.Cells(ii, 1) Then
                For iii = 13 To Columns.Count Step 4
                    If Cells(i, iii) = "" Then
                        Cells(i, iii).Resize(1, 4).Value = s2.Cells(ii, 2).Resize(1, 4).Value
                        Exit For
                    End If
                Next iii
            End If
        Next ii
    Next i
    Set s1 = Nothing
    Set s2 = Nothing
End Sub

Çok teşekkürler. Sorum çözülmüştür.. Allah razı olsun. Saygılar.