verileri uygun sutunlara yazdırma

[senerozun]

Bu çalışma ile ilgi daha önce Koray beyden yardım aldım. Koray Beyin ellerine saglık. çok güzel olmuş. makro çok güzel çalışıyor. Benim ufak bir sorum olacaktı. Aynı örnekte "J" sutunundan verileri alarak adı: soyadı: baba adı: kısımlarını makro ile çok güzel yazdırabiliyoruz. Aynı örnekte bu sefer " J " sutununda virgül olmadığı zamanda ayırmayı makro ile nasıl yapabiliriz. Yazdığınız makro kodu , kod sayfasına yapıştırdım örneğime. Bu sefer tek farkı J sutunda virgül bulunmayısı. Bunu nasıl çözebiliriz. yardımcı olabilirseniz sevinirim.

 

[Korhan Ayhan]

Selamlar,

İsimler arasında 28 karakter uzunluğunda boşluk kullanılmış. Bu kriteri dikkate alarak aşağıdaki kodu hazırladım. İncelermisiniz.

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, [COLOR=red]BOŞLUK As String[/COLOR]
    
    For X = 13 To ActiveSheet.UsedRange.Rows.Count
        If Cells(X, "J") <> "" Then
            SAY = 0
            [COLOR=red]BOŞLUK = WorksheetFunction.Rept(Chr(32), 28)
[/COLOR]            VERİ = Split(Cells(X, "J"), [COLOR=red]BOŞLUK[/COLOR])
            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 , emeğinize ve ellerinize sağlık. Bu şekilde sorunum çözüldü. Makro çok güzel çalışıyor. Çok teşekkürler.