Soru Tek Hücredeki İki Satırı Ayrı İki Hücreye Yazdırma

[officer08]

A1 HÜCRESİNDE (TEK HÜCREDE) ALT ALTA TC NUMARASI VE AD SOYADDAN OLUŞAN SATIRLAR YAZILI

YANİ ŞÖYLE GİBİ;
-----------------------------------
11111111111 Kemal TOSUN
22222222222 Hasan KÜÇÜK
33333333333 Temel SAMAN
-----------------------------------

BUNLARI MESELA B1-B2-B3 GİBİ AYRI HÜCRELERE TEK TEK YAZDIRMAK VEYA KOPYALAMAK İSTİYORUM. BEN YAPAMADIM YARDIMCI OLURSANIZ SEVİNİRİM TEŞEKKÜRLER.

 

[PLİNT]

Merhaba
Aşağıdaki kodlarla deneyin, bir hücre için;
https://we.tl/t-VQbN3xJjs9

Sub ayır()
For a = 0 To UBound(Split([A1], Chr(10)))
Cells(a + 1, "B") = Split([A1], Chr(10))(a)
Next
End Sub

 

[gicimi]

Sayın @PLİNT Kodu inceler misiniz. A1 hücresindeki yazılı veriyi ayırmadan B1 hücresine yazıyor. Sayıları B2 hücresine ve Metini B3 hücresine ayırmak için kodu güncelleyebilir misiniz. Teşekkürler.

 

[PLİNT]

Merhaba
Konu sahibinin yukarıdaki mesajında isteği:
A1 HÜCRESİNDE (TEK HÜCREDE) ALT ALTA TC NUMARASI VE AD SOYADDAN OLUŞAN SATIRLAR YAZILI
silinmiş dosya;
http://dosya.co/cvzs4jur5ii3/ayır.zip.html
Sizin isteğiniz
"A" sütununda alt hücrelerde yazanlar için gibi anlaşılıyor ona göre bir küçük örnek dosya eklerseniz üzerinde yapmaya çalışalım
Aşağıdaki kodlarla; satırlardaki sayı ve metin biçimi yukarıdaki (11111111111 Kemal TOSUN ) gibi olmalı, metin içinde sayı olması hata verdirecektir.
Dosyadaki kodlar;

Sub ayır()
For a = 1 To Cells(Rows.Count, "A").End(3).Row
Cells(a, "B") = RetNum(Cells(a, 1).Text)
Cells(a, "C") = Split(Cells(a, 1).Text, Cells(a, "B").Text)(1)
Next

End Sub
Function RetNum(AnyStr As String)
    Dim RegEx
    Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
        .Global = True
        .Pattern = "[^\d]+"
    End With
    RetNum = RegEx.Replace(AnyStr, "")
    Set RegEx = Nothing
End Function

 

[gicimi]

Sayın @PLİNT örnek,

 

[PLİNT]

Altın üye olmadığım için dosyanızı forumdan indiremiyorum
İstediğiniz ek dosyadaki gibi olabilir
http://dosya.co/9dk21tchcrgo/ayır2.zip.html
değilse örneğinizi buraya eklermisiniz: http://dosya.co/

 

[gicimi]

@PLİNT teşekkür ederim. yapmak istediğim budur. Elinize sağlık.

 

[PLİNT]

@PLİNT teşekkür ederim. yapmak istediğim budur. Elinize sağlık.

Rica ederim. geri dönüşünüz için teşekkür ederim, kolay gelsin

 

[Ömer BARAN]

Merhaba.
Ben de hazırlamıştım, göndereyim bari. Alternatif olsun.

Sub TC_ISIM_AYIR()
For sat = UBound(Split([A1], Chr(10))) To 0 Step -1
    Cells(sat + 1, 1) = Split([A1], Chr(10))(sat)
    Cells(sat + 1, 2) = Split(Split([A1], Chr(10))(sat), Chr(32))(0)
    Cells(sat + 1, 3) = Trim(Replace(Split([A1], Chr(10))(sat), Cells(sat + 1, 2), ""))
Next
End Sub

 

[officer08]

Arkadaşlar geç bakabildim size teşekkür edemedim kusura bakmayın. Başta PLİNT olmak üzere çok teşekkür ederim cevabınız için. Çok yardımcı oldu ancak yeni bir durum oluştu şöyleki. A1,A2,A3 ve devamında alt alta tek hücreye yazılı, birden fazla satırlı veya tek satırlı veriler var bunları Sayfa2 de A (TC NO) ve B (AD SOYAD) sütununa yukarıdan aşağı sırayla tek satır olacak şekilde yazdırmak istiyorum yardımcı olursanız çok sevinirim.

-----------------------------------
11111111111 Kemal TOSUN
22222222222 Hasan KÜÇÜK
33333333333 Temel SAMAN
-----------------------------------
11111111111 Kemal TOSUN
22222222222 Hasan KÜÇÜK
----------------------------------
22222222222 Hasan KÜÇÜK

A sütununda aşağı doğru sıralı (A1,A2,A3) bu veriler Sayfa2 de A sütununa alt alta tc nolar B sütununa ad soyad olarak sıralanacak

 

[PLİNT]

Merhaba
Ek dosyadaki gibi deneyelim
https://dosya.co/fy73hnuvyms0/ayır2.zip.html

Sub ayır()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
For a = 1 To s1.Cells(Rows.Count, "A").End(3).Row
s2.Cells(a, "A") = RetNum(s1.Cells(a, 1).Text)
s2.Cells(a, "B") = Split(s1.Cells(a, 1).Value, s2.Cells(a, "A").Value)(1)
Next

End Sub
Function RetNum(AnyStr As String)
    Dim RegEx
    Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
        .Global = True
        .Pattern = "[^\d]+"
    End With
    RetNum = RegEx.Replace(AnyStr, "")
    Set RegEx = Nothing
End Function

 

[officer08]

PLİNT çok sağol cevabın için ancak. Sayfa2 atılan veri tam benim istediğim gibi ancak sayfa1 A sütunundaki veriler her hücrede 1 satır değil. her hücrede 1 veya birden fazla satır var. Mesela aşağıdaki çizgi aralıkları tek hücre gibi düşüneceğiz . Seninkinde her hücrede 1 satır var.
-----------------------------------
11111111111 Kemal TOSUN
22222222222 Hasan KÜÇÜK
33333333333 Temel SAMAN
-----------------------------------
11111111111 Kemal TOSUN
22222222222 Hasan KÜÇÜK
----------------------------------
22222222222 Hasan KÜÇÜK

 

[PLİNT]

Deneyelim
https://dosya.co/58ikewfo904t/ayır3.zip.html
Olmazsa örnek dosya ekleyin

Sub ayır()
Dim c As String
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
For a = 1 To s1.Cells(Rows.Count, "A").End(3).Row
For b = 0 To UBound(Split(s1.Cells(a, 1), Chr(10)))
x = x + 1
c = Split(s1.Cells(a, 1), Chr(10))(b)
s2.Cells(x, "A") = RetNum(c)
s2.Cells(x, "B") = Split(c, s2.Cells(x, "A"))(1)
Next
Next
End Sub
Function RetNum(AnyStr As String)
    Dim RegEx
    Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
        .Global = True
        .Pattern = "[^\d]+"
    End With
    RetNum = RegEx.Replace(AnyStr, "")
    Set RegEx = Nothing
End Function

 

[Ömer BARAN]

Merhaba.
Alternatif olsun.
Verilerin Sayfa1 A2 'den itibaren A sütununda listelendiği varsayılmış olup sonuçlar Sayfa2 A ve B sütununa listelenir.

Sub TC_ISIM_AYIR()
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
s2.[A:B].ClearContents
For satt = 2 To s1.Cells(Rows.Count, 1).End(3).Row
    For sat = 0 To UBound(Split(s1.Cells(satt, 1), Chr(10)))
        s = s2.Cells(Rows.Count, 2).End(3).Row + 1
        s2.Cells(s, 1) = Split(Split(s1.Cells(satt, 1), Chr(10))(sat), Chr(32))(0)
        s2.Cells(s, 2) = Trim(Replace(Split(s1.Cells(satt, 1), Chr(10))(sat), s2.Cells(s, 1), ""))
    Next: Next: s2.Columns("A:B").AutoFit
End Sub

 

[officer08]

PLİNT ve Ömer BARAN ikinize de çok teşekkür ederim denedim oldu, sayenizde büyük kolaylık olacak