koşullu makro ya da başka bir yol

[meleklerim]

Arkadaşlar bir excel belgesinde a1, a2,... a6 satırlarında birbirlerinden
"@" işareti ile ayrılmış veriler bulunmakta.
Örnek: A1 satırında
Orhan Boran;Yıldırım Beyazıt@Cahit Irgat;-@Lale Oraloğlu;-@Pola Morelli;-@Daisy;-@Atıf Kaptan;-@Şadıman Ayşın;-@Feridun Çölgeçen;-@Mücap Ofluoğlu;-@Vahi Öz;-


benim istediğim @Orhan Boran;Yıldırım Beyazıt
formatında yazılmış bu verilerden ";" sonraki girişi (Yıldırım Beyazıt) dikkate almayıp sadece "@" ile ";" arasındaki girişi, yani (Orhan Boran) ı dikkate almasıdır.
Bu dikkate alacağı verileri aynı belgenin
*Başka bir sayfasında
*Birbirinin aynısı girişleri tek girişe düşürerek alt alta sıralamasını
*yanındaki sütuna da o veriden kaç adet bulunduğunun
yazılmasını
sağlayan bir makro...

örnek dosya
http://dosya.co/i57r5hankydn/koşullu_makro.xlsx.html

alternatif

http://dosya.web.tr/Krp2YO

 

[Orion1]

Dosyanız exe dosya.excel dosyası değil.

 

[meleklerim]

Dosyanız exe dosya.excel dosyası değil.

nasıl olur? zaten adında da xlsx uzantısı var???

Upload sitesinin sayfasındaki yeşil renkli altında sponsor yazan butona bastınız herhalde.
Aşağıda daha küçük bir gri renkli buton var. ona tıklayarak indirin lütfen

 

[Orion1]

A sütununu seçiniz,Excelde veri sekmesinde metni sütunlara dönştürden sınırlandırılmışı seçin.ileri tıklayın.çıkan pencerede noktalı virgülü tıklayıp sonu tıklayın.

 

[meleklerim]

A sütununu seçiniz,Excelde veri sekmesinde metni sütunlara dönştürden sınırlandırılmışı seçin.ileri tıklayın.çıkan pencerede noktalı virgülü tıklayıp sonu tıklayın.

sadece bir tane @ ile ayrılmamış sayın Orion1
ayrıca benim istediğim herbirinin birer hücreye yazılması değil ki...
Örnek dosyayı indirseniz ne istediğimi daha rahat anlayacaksanız

 

[Saban Sertkaya]

dosya.co sitesi yerine dosya.web.tr sitesini kullanın. Daha problemsiz.

 

[meleklerim]

dosya.co sitesi yerine dosya.web.tr sitesini kullanın. Daha problemsiz.

buyrun sayın saban20152015

http://dosya.web.tr/Krp2YO

 

[Saban Sertkaya]

Size sadece daha problemsiz bir upload sitesi önerdim. Önceki upload ettiğiniz siteden dosyanıza zaten bakmıştım.

Buyrun sayın meleklerim

Örnek dosyanız veya kod hali,

http://dosya.web.tr/KDwb1N

Sub Düğme1_Tıklat()
Dim a, b, c, d, e, f, g
g = 1
Sheets(2).Columns("A:B").ClearContents
For a = 1 To [A65536].End(xlUp).Row
c = 0: d = 0: e = 0
b = Len(Cells(a, 1))
For c = 1 To b
If Mid(Cells(a, 1), c, 1) = "@" Then d = c
If Mid(Cells(a, 1), c, 1) = ";" Then
e = c
If d = 0 Then
e = 0
GoTo 10
End If
Sheets(2).[A65536].End(xlUp).Offset(1, 0) = Mid(Cells(a, 1), d + 1, e - d - 1)
End If
10
Next c
Next a


Sheets(2).Select
[A2].Select
[A2:A65536].Sort Key1:=[A2]

For f = [A65536].End(xlUp).Row To 2 Step -1
If Cells(f, 1) = Cells(f - 1, 1) Then
g = g + 1
Cells(f - 1, 2) = g
Cells(f, 1).EntireRow.Delete
Else
g = 1
End If
Next f
End Sub

 

[meleklerim]

çok teşekkür ederim arkadaşım.
Yalnız ufak bir hata var; ilk verinin başında @ işareti olmadığından onu saymıyor.
Ben hemen yanındaki sütuna @ işareti koyup birleştirme yaptım. Onu makronun içine nasıl ekleyebiliriz?
kısaca eklemek istediğim
Her satırın başına @ ekle komutu olmalı



Bir de şimdi asıl kendi üzerinde çalıştığım dosyada denedim. Hata verdi. hata kodu #400
biraz inceleyince alta alta sıralarken 65.000 satır sınırının yetmediğini gördüm.
makroya: alt alta sıralarken 65 bin satır sınırı aşılınca 2. sütuna geç, o da aşılınca 3. sutuna geç denilebilir mi?

çok çok teşekkürler

 

[Saban Sertkaya]

Revize edilmiş aşağıdaki kodu kullanın.
Verilerin başında @ işareti yok ise, eklenecektir. Ayrıyeten Office 2013 kullandığınıza göre satır sınırınız 1048576 olacaktır. O halde 2.sütuna geç demeye gerek yoktur. 65536 görünen yerlere 1048576 yazmak yeterli olacaktır.

Sub Düğme1_Tıklat()
Dim a, b, c, d, e, f, g
g = 1
Sheets(2).Columns("A:B").ClearContents
For a = 1 To [A1048576].End(xlUp).Row
c = 0: d = 0: e = 0

If Mid(Cells(a, 1), 1, 1) <> "@" Then Cells(a, 1) = "@" & Cells(a, 1)

b = Len(Cells(a, 1))
For c = 1 To b
If Mid(Cells(a, 1), c, 1) = "@" Then d = c
If Mid(Cells(a, 1), c, 1) = ";" Then
e = c
If d = 0 Then
e = 0
GoTo 10
End If
Sheets(2).[A1048576].End(xlUp).Offset(1, 0) = Mid(Cells(a, 1), d + 1, e - d - 1)
End If
10
Next c
Next a


Sheets(2).Select
[A2].Select
[A2:A1048576].Sort Key1:=[A2]

For f = [A1048576].End(xlUp).Row To 2 Step -1
If Cells(f, 1) = Cells(f - 1, 1) Then
g = g + 1
Cells(f - 1, 2) = g
Cells(f, 1).EntireRow.Delete
Else
g = 1
End If
Next f
End Sub

 

[meleklerim]

mükemmel ötesi.
9 bin civarında satırda bulunan 250 binden fazla veri girişini süzüp, 28 bin tekil veriye düşürdü. Benim 1 haftalık işimi yarım saatte çözdü.
ellerinden öpüyorum
(bizde ustaların ellerinden öpülür)

 

[Saban Sertkaya]

Berhudar olun. Biz de eskidik zaten.