anahtara göre 2.sayfaya data atma

[catalinastrap]

Merhabalar,

DATA	DAĞITIM
A2	C2;D2;E2
B2	O3
C2	P3
D2	F2
E2	O4
F2	Q4

Excel de yukarıda eşleştirme tablosuna göre sayfa1 den sayfa2 ye data atmak istiyorum uzun bir listem var . Bunu yaparken dağıtım sayfasına her kayıt için 3 satır ekleyerek ekleyerek A Sütununda H-L-L açılmalı ve dağıtım sonra yapılmalı daha sonra diğer kod devam etmeli döngüde

 

[catalinastrap]

konu biraz acil arkadaşlar

 

[Muzaffer Ali]

Merhaba.
Kodu Data sayfasının kod kısmına kopyalayıp çalıştırınız.

Sub Test()
    Dim Bak As Long
    Dim SonSatir As Long
   
    With Worksheets("dağıtım")
        For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
            SonSatir = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Cells(SonSatir, "A") = "H"
            .Range("A" & SonSatir + 1 & ":A" & SonSatir + 2).Value = "L"
            .Range("C" & SonSatir & ":E" & SonSatir).Value = Cells(Bak, "A").Value
            .Cells(SonSatir, "F") = Cells(Bak, "D")
            .Cells(SonSatir + 1, "O") = Cells(Bak, "B")
            .Cells(SonSatir + 1, "P") = Cells(Bak, "C")
            .Cells(SonSatir + 2, "O") = Cells(Bak, "E")
            .Cells(SonSatir + 2, "Q") = Cells(Bak, "F")
        Next
    End With
    MsgBox "Tamamlandı", vbInformation
End Sub

 

[catalinastrap]

Merhaba.
Kodu Data sayfasının kod kısmına kopyalayıp çalıştırınız.

Sub Test()
    Dim Bak As Long
    Dim SonSatir As Long
  
    With Worksheets("dağıtım")
        For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
            SonSatir = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Cells(SonSatir, "A") = "H"
            .Range("A" & SonSatir + 1 & ":A" & SonSatir + 2).Value = "L"
            .Range("C" & SonSatir & ":E" & SonSatir).Value = Cells(Bak, "A").Value
            .Cells(SonSatir, "F") = Cells(Bak, "D")
            .Cells(SonSatir + 1, "O") = Cells(Bak, "B")
            .Cells(SonSatir + 1, "P") = Cells(Bak, "C")
            .Cells(SonSatir + 2, "O") = Cells(Bak, "E")
            .Cells(SonSatir + 2, "Q") = Cells(Bak, "F")
        Next
    End With
    MsgBox "Tamamlandı", vbInformation
End Sub

Merhabalar,
çok teşekkür ederim ellerinize sağlık süper olmuş