verileri ilgili satırlara yazdırma sorunu

[senerozun]

benim excel tablolarında makrolar kısmında çözemediğim bir sorun var. Daha önceli bir excel tablosunda bir örnek üzerinde bana bir makro kod oluşturmuştunuz. ben bu kodu exceldeki makro kod sayfasına yapıştırdım. makro çalışıyor fakat 1. satırı aynen istediğim gibi yapıyor. ama her neyse 2. satıra geldiğinde hücre içindeki veriler aynı koşulda olmasına rağmen 2. satırda takılıyor. ben örneğimde sizin yazdığınız makroyu yapıştırdım. eğer bir inceleyebilirseniz çok sevinirim. iyi günler dilerim. Ayrıca çalışmalarınızda başarılar dilerim. Saygılarımla.
not: gönderdiğim örnekte makroyu çalıştırırsanız ilk satırın çalıştığını sonrakilerin çalışmadığını göreceksiniz.

 

[Korhan Ayhan]

Selamlar,

Sorun J sütunundaki kişilerden "ŞAZİYE İREK" isimli kişinin baba adının olmamasından kaynaklanıyor. Ben her kişinin baba adı olacak varsayımıyla makroyu tasarlamıştım. Bu sorunuda kodun içine bir eğer-if sorgusu ekleyerek kolaylıkla aşabiliriz.

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub VERİLERİ_DÜZENLE()
    Dim X As Long, VERİ() As String, SATIR As Long
    Dim Y As Long, SAY As Byte, KELİME() As String
    
    For X = 13 To ActiveSheet.UsedRange.Rows.Count
        If Cells(X, "J") <> "" Then
            SAY = 0
            VERİ = Split(Cells(X, "J"), ",")
            SATIR = UBound(VERİ()) + 1
            Range("A" & X + 1 & ":R" & X + SATIR).Insert Shift:=xlDown
            Range("A" & X + 1 & ":R" & X + SATIR).Interior.ColorIndex = 15
            
            For Y = X + 1 To X + SATIR
                If VERİ(SAY) <> "" Then KELİME = Split(VERİ(SAY), " ")
                If UBound(KELİME) = 1 Then
                    Cells(Y, "E") = KELİME(0)
                    Cells(Y, "F") = Replace(KELİME(1), Chr(10), "")
                    SAY = SAY + 1
                Else
                    Cells(Y, "E") = KELİME(0)
                    Cells(Y, "F") = Replace(KELİME(1), Chr(10), "")
                    Cells(Y, "G") = Replace(Replace(KELİME(2), Chr(10), ""), ":", "")
                    SAY = SAY + 1
                End If
            Next
            X = X + SATIR - 1
        End If
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[senerozun]

Korhan bey çok teşekkür ederim. Bu şekilde yapınca sorunum çözüldü.