Koşula bağlı satır ekleme ve o satırlara veri taşıma

[a_ceylan]

Üstadlar sizden bir ricam var dosya ekleyemiyorum ama kısaca anlatmaya çalışacağım.


f sütunundan başlayıp t ye kadar olan bölümde ki dolu olan hücre sayısı kadar altına boş satır ekleyecek ve boş satırlara a,b,c sutunlarındakini aynen kopyalaycak tekrar f sütunundan başlayarak t ye kadar dolu olan hücreyi yeni oluşturduğu satırın d sütununa e sütununa ise f sutunu dolu ise ak sütunundaki değeri g dolu ise al sütunundaki değeri sırası ile ay sütununa kadar taşıyacak ve değerin olduğu satırı silecek bu hareketi a sütunun son boş hücreye kadar devam ettirecek













yani;

A B C D E F G H AK AL AM

111 ahmet ceylan 2 1 2 20 35 28

111 ahmet ceylan 2 20

111 ahmet ceylan 1 35

111 ahmet ceylan 2 28

 

[ÖmerBey]

Merhaba,
Dosyanızın yedeğini aldıktan sonra aşağıdaki kodu deneyiniz.

Sub KOD()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For a = Range("A65500").End(3).Row To 2 Step -1
    kn = Cells(a, "A")
    ad = Cells(a, "B")
    soyad = Cells(a, "C")
    
    For b = 20 To 6 Step -1
        If Cells(a, b) <> "" Then
            Rows(a + 1).Insert
            Cells(a + 1, "A") = kn
            Cells(a + 1, "B") = ad
            Cells(a + 1, "C") = soyad
            Cells(a + 1, "D") = Cells(a, b)
            Cells(a + 1, "E") = Cells(a, b + 31)
        End If
    Next
    Rows(a).Delete
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Not: Dosyanızda kimlik numarası ve ad soyad gibi özel bilgiler bulunduğu için dosyanızı paylaşımdan kaldırmanızı tavsiye ederim.
İyi çalışmalar...

 

[a_ceylan]

Üstadım harikasın çok çok teşekkür ederim. Allah razı olsun

Çalışma alanın farklı sayfada olmasından dolayı bir kaç değişiklik yaptım

son hali budur

Sub SABLON()

Cells.Select
    Selection.Copy
    Sheets("SABLON").Select
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
 Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For a = Range("A65500").End(3).Row To 2 Step -1
    kn = Cells(a, "A")
    ad = Cells(a, "B")
    soyad = Cells(a, "C")
    
    For b = 20 To 6 Step -1
        If Cells(a, b) <> "" Then
            Rows(a + 1).Insert
            Cells(a + 1, "A") = kn
            Cells(a + 1, "B") = ad
            Cells(a + 1, "C") = soyad
            Cells(a + 1, "D") = Cells(a, b + 31)
            Cells(a + 1, "E") = Cells(a, b)
        End If
    Next
    Rows(a).Delete
    

Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

ActiveSheet.Range("F1:AY1").Delete
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").Select
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").Select
    Columns("C:C").EntireColumn.AutoFit
    ActiveSheet.Range("A1:E1").Delete
    Range("F2").Select
End Sub

son olarak birşey sormak istiyorum değerleri yapıştırınca e sütunundaki değerlerin bazılarını hata olarak görüyor excel hücreyi sayıya dönüştürmek gerekiyor bunu nasıl düzeltebilirim.

 

[ÖmerBey]

İlgili satırları şu şekilde düzeltin.

Cells(a + 1, "D") = Cells(a, b + 31)[COLOR="Red"].Value[/COLOR]
Cells(a + 1, "E") = Cells(a, b)[COLOR="red"].Value[/COLOR]

 

[a_ceylan]

Teşekkürler :bravo::bravo: