Hücre İçerisindeki Alt Alta Olan Verileri Diğer Sayfaya Ayırarak Yazdırma

[officer08]

sayfa1 A sütununda hücrelerde bulunan verileri (bazı hücrelerde 2 veya daha fazla satır bulunuyor) sayfa2 deki yine A sütunu altındaki hücrelere (her hücreye tek veri gelecek şekilde, yani sayfa1 deki bazı hücrelerdeki birden fazla satırlık olanları da ayırarak) yazdırmak istiyorum. Bunu nasıl bir kodla yazdırabilirim.

Yardımcı olursanız sevinirim. Şimdiden teşekkürler.https://s6.dosya.tc/server3/0wioo0/ornek.xlsx.html

 

[excelokyanus500]

Deneyin. Alıtıdır

Sub Hucre_Ayır()
    Dim X As Long, Y As Integer, Z As Integer
    Dim VeriA As Variant, VeriB As Variant
    Dim son As Long, Satir As Long, Sutun As Integer
    Set syf = Sheets("Sayfa2")
    Set syfa = Sheets("Sayfa1")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    son = syfa.Cells(Rows.Count, 1).End(3).Row
    syf.Range("B1").Resize(1, Columns.Count - 1).EntireColumn.Clear
    syf.Range("B1").Resize(1, Columns.Count - 1).ColumnWidth = 10
    Satir = 1
    Sutun = 2
    
    For X = 1 To son
        If syfa.Cells(X, 1) <> "" Then
            VeriA = Split(syfa.Cells(X, 1).Value, Chr(10))
            For Y = 0 To UBound(VeriA)
                VeriB = Split(VeriA(Y), " ")
                For Z = 0 To UBound(VeriB)
                    If InStr(1, VeriB(Z), "") = 0 Then
                        syf.Cells(Satir, Sutun) = Mid(VeriB(Z), 1, Len(VeriB(Z)) - 1)
                        Sutun = Sutun + 2
                        syf.Cells(Satir, Sutun) = " "
                  
                
                
                        Sutun = Sutun + 2
                    Else
                      syf.Cells(Satir, 1) = VeriB(Z)
                        Sutun = Sutun + 2
                    End If
                Next
                Satir = Satir + 1
                Sutun = 2
            Next
        End If
    Next

    syf.Range("B1").Resize(1, Columns.Count - 1).EntireColumn.AutoFit

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation

End Sub

 

[officer08]

Çok teşekkür ederim tam istediğim gibi. Lakin kodları açınca kendim uyarlayabilirim sandım ama başaramadım. Acaba sayfa1 B sütununu sayfa2 B Sütununa kopyalacak şekilde uyarlamam gerekirse kodların hangi kısımlarını değiştirmem gerekir.

 

[excelokyanus500]

Deneyin

Sub Hucre_Ayır()
    Dim X As Long, Y As Integer, Z As Integer
    Dim VeriA As Variant, VeriB As Variant
    Dim son As Long, Satir As Long, Sutun As Integer
    Set syf = Sheets("Sayfa2")
    Set syfa = Sheets("Sayfa1")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    son = syfa.Cells(Rows.Count, 2).End(3).Row
    syf.Range("B1").Resize(1, Columns.Count - 1).EntireColumn.Clear
    syf.Range("B1").Resize(1, Columns.Count - 1).ColumnWidth = 10
    Satir = 1
    Sutun = 2
    
    For X = 1 To son
        If syfa.Cells(X, 2) <> "" Then
            VeriA = Split(syfa.Cells(X, 2).Value, Chr(10))
            For Y = 0 To UBound(VeriA)
                VeriB = Split(VeriA(Y), " ")
                For Z = 0 To UBound(VeriB)
                    If InStr(1, VeriB(Z), "") = 0 Then
                        syf.Cells(Satir, Sutun) = Mid(VeriB(Z), 1, Len(VeriB(Z)) - 1)
                        Sutun = Sutun + 2
                        syf.Cells(Satir, Sutun) = " "
                  
                
                
                        Sutun = Sutun + 2
                    Else
                      syf.Cells(Satir, 2) = VeriB(Z)
                        Sutun = Sutun + 2
                    End If
                Next
                Satir = Satir + 1
                Sutun = 2
            Next
        End If
    Next

    syf.Range("B1").Resize(1, Columns.Count - 1).EntireColumn.AutoFit

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation

End Sub

 

[officer08]

Sağolasın excelokyanus500

sorun çözüldü.

 

[officer08]

excelokyanus500 'ün vermiş olduğu kodla sorunu çözmüştüm aynı hücredeki satırları farklı hücrelere ayırabildim ancak şöyle bir problem çıktı eğer bir satırdaki veri mesela isim soyisim şeklinde ise sadece ilk kelimeyi yani ismi atıyor soyisim görünmüyor, oysa benim istediğim o satırda ne varsa o şekilde atması. Yardımcı olursanız çok sevinirim.

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kodu deneyin.

Sub test()
    Dim i As Variant
    Dim bak As Integer, Isim As Integer, Say As Integer
    Dim syf1 As Worksheet, syf2 As Worksheet
    Set syf1 = Worksheets("Sayfa1")
    Set syf2 = Worksheets("Sayfa2")
    syf2.Range("A:A").ClearContents
    For bak = 1 To syf1.Cells(Rows.Count, "A").End(xlUp).Row
        i = Split(syf1.Cells(bak, "A"), Chr(10))
        For Isim = 0 To UBound(i)
            Say = syf2.Cells(Rows.Count, "A").End(xlUp).Row + 1
            If syf2.Range("A1") = "" Then Say = 1
            syf2.Cells(Say, "A") = i(Isim)
        Next
    Next
End Sub

 

[YUSUF44]

Merhaba.
Aşağıdaki kodu deneyin.

Sub test()
    Dim i As Variant
    Dim bak As Integer, Isim As Integer, Say As Integer
    Dim syf1 As Worksheet, syf2 As Worksheet
    Set syf1 = Worksheets("Sayfa1")
    Set syf2 = Worksheets("Sayfa2")
    syf2.Range("A:A").ClearContents
    For bak = 1 To syf1.Cells(Rows.Count, "A").End(xlUp).Row
        i = Split(syf1.Cells(bak, "A"), Chr(10))
        For Isim = 0 To UBound(i)
            Say = syf2.Cells(Rows.Count, "A").End(xlUp).Row + 1
            syf2.Cells(Say, "A") = i(Isim)
        Next
    Next
End Sub

Sayın Muzaffer Ali, 0 to ubound(i) denildiğinde dizi 3 elemanlıysa 0 to 3 olmaz mı? Bu da i=3 olduğunda hataya neden olmaz mı?

 

[officer08]

Ellerini sağlık Muzaffer Ali teşekkür ederim. Sadece Sayfa2 ye atarken A1 satırını boş bırakıp A2 den başlayarak aşağı sıralıyor acaba nereyi düzeltmeliyiz

 

[officer08]

Yusuf44 eğer doğru anladıysam A1 hücresindeki ilk satırda mesela "Hasan Salih SÖNMEZ" şeklinde metin verisi var aynı hücrenin alt satırında da yine 3 kelimelik metin verisi var sayfa 2 A2 hücresine ve A3 hücresine 3 er kelimelik tam bir şekilde ayrı bir şekilde atıyor ancak A1 hücresini atlıyor

 

[Muzaffer Ali]

Sayın Muzaffer Ali, 0 to ubound(i) denildiğinde dizi 3 elemanlıysa 0 to 3 olmaz mı? Bu da i=3 olduğunda hataya neden olmaz mı?

Ubound eleman sayısını vermez, son elemanın dizi numarasını verir.
Eğer i 3 elemanlıysa son elemanın dizi numarası 2 olur.

 

[Muzaffer Ali]

Ellerini sağlık Muzaffer Ali teşekkür ederim. Sadece Sayfa2 ye atarken A1 satırını boş bırakıp A2 den başlayarak aşağı sıralıyor acaba nereyi düzeltmeliyiz

Yukardaki kodu güncelledim.

 

[officer08]

Sorun çözüldü çok sağolun