Satır ekleme ve eklenen satırların yanına veri girme

[bebar]

Merhaba,


P sutununda bulunan dolu hücre sayısı kadar e,f,g sütunlarında bulunan her bir dolu hücre için satır eklemek ve eklenen satırların yanına p sütunda bulunan verileri yapıştırmak istiyorum, benzer örnekler var fakat pek başarılı olamadım dosyam ektedir.

Teşekkür ederim.

 

[askm]

Sayfa1 adında yeni bir sayfa ekleyerek aşağıdaki kodları kullanabilirsiniz.

Sub askm()
Dim SonSat1, SonSat2 As Long
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sayfa1")
SonSat1 = s1.Range("P65536").End(xlUp).Row
SonSat2 = s1.Range("E65536").End(xlUp).Row
Range("E3:H65000").ClearContents
a = 3
For x = 3 To SonSat2
    For i = 2 To SonSat1
        s2.Cells(a, 5) = s1.Cells(x, 5)
        s2.Cells(a, 6) = s1.Cells(x, 6)
        s2.Cells(a, 7) = s1.Cells(x, 7)
        s2.Cells(a, 8) = s1.Cells(i, 16)
        a = a + 1
    Next i
Next x
MsgBox "Aktarma işlemi tamam...", vbInformation, "ASKM"
End Sub

 

[bebar]

hocam teşekkür ederim ama

run time eror "9"

sunscript out of range

hatası veriyor

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Sub ekle()
adet = WorksheetFunction.CountA([P:P]) - 1
sonE = Cells(Rows.Count, "E").End(3).Row
sonP = Cells(Rows.Count, "P").End(3).Row
For i = sonE To 3 Step -1
    Range("E" & i & ":H" & i).Copy
    Range("E" & i + 1 & ":H" & i + adet).Select
    Selection.Insert Shift:=xlDown
    Range("P2:P" & sonP).Copy Cells(i, "H")
Next
End Sub

 

[bebar]

çok teşekkür ederim çok faydası oldu