• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

O

officer08

Katılım
29 Mart 2013
Mesajlar
144
Excel Vers. ve Dili
office 2010
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
 
Deneyin. Alıtıdır

Kod: 
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
 
Ç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.
 
Deneyin

Kod: 
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
 
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.
 
Merhaba.
Aşağıdaki kodu deneyin.

Kod: 
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
 
Son düzenleme:
Muzaffer Ali' Alıntı:
Merhaba.
Aşağıdaki kodu deneyin.

Kod: 
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
Genişletmek için tıkla ...
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ı?
 
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
 
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
 
YUSUF44' Alıntı:
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ı?
Genişletmek için tıkla ...
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst