Cümlenin arasında geçen kelimeyi almak

[yelgecak]

S.a

Hat No/Adı:1/01 ILGIN Tarih:29.06.2012
Hat No/Adı:2/02 CUMRA Tarih:29.06.2012
Hat No/Adı:3/03 ZAFER-MERKEZ Tarih:29.06.2012
Hat No/Adı:4/04 FATİH IŞIKLAR Tarih:29.06.2012

yukarıdaki yazılar hücre içinde hepsi cümle olarak geçiyor. kapalı dosyadan veri çekerek alıyorum hepsi değişik hücrelere denk geliyor. her zaman aynı hücreye denk gelmiyor yani.

yapmak istediğim ise

Hat No/Adı:1/01 ILGIN Tarih:29.06.2012
Hat No/Adı:2/02 CUMRA Tarih:29.06.2012
Hat No/Adı:3/03 ZAFER-MERKEZ Tarih:29.06.2012
Hat No/Adı:4/04 FATİH IŞIKLAR Tarih:29.06.2012

Hat No/Adı:1/01, Hat No/Adı:2/02, Hat No/Adı:3/03 gibi cümleleri bulup ondan sonra gelen kelimeleri B1 hücresine yazmak. Yani ILGIN, CUMRA, ZAFER-MERKEZ, FATİH IŞIKLAR bunları
B1 hücresine yazdırmak istiyorum ama "Hat No/Adı:1/01 ILGIN Tarih:29.06.2012" 01 ile Tarih arasındaki ILGIN Kelimesini almak istiyorum.

=EĞER(EĞERSAY(Sayfa1!A1:AZ1000;"*Hat No/Adı:1/01*")>0;2;"")

Yukarıdaki Formül İle A1 ile AZ1000 arasındaki Hat No/Adı:1/01 geçen kelimeyi buluyorum

VBA koduda olabilir

yardımlarınızı bekliyorum, teşekkürler

 

[SATYON]

benzer bir dosyada kullandığım aşağıdaki formülü kendi dosyanıza uyarlayabilirsiniz belki... ben bu formülü aynı hücredeki ad soyad bilgisini ayrı hücrelere almak için kullanıyorum...

SOLDAN(YERİNEKOY(A1;" ";"*";UZUNLUK(A1)-UZUNLUK(YERİNEKOY(A1;" ";"")));BUL("*";YERİNEKOY(A1;" ";"*";UZUNLUK(A1)-UZUNLUK(YERİNEKOY(A1;" ";"")));1)-1)

PARÇAAL(A1;UZUNLUK(B1)+2;UZUNLUK(A1)-UZUNLUK(B1))

 

[tahsinanarat]

Ekli dosyayı inceleyiniz

Örnek dosya verseydiniz iyi olurdu, ancak anladığım kadarıyla yapmaya çalıştım, umarım olmuştur.

 

[Murat OSMA]

Şu kodları bir deneyiniz;

Sub Emre()
    Dim Reg As Object
    Dim i As Integer
    For i = 2 To Range("A65536").End(3).Row
        Cells(i, 1) = Replace(Cells(i, 1), " ", "", 1, 1)
    Set Reg = CreateObject("VBScript.RegExp")
    Reg.Global = True
    Reg.Pattern = "\s\w+\S+"
    Set say = Reg.Execute(Cells(i, 1))
        If say.Count > 0 Then
            Cells(i, 2) = Reg.Execute(Cells(i, 1)).Item(0)
        End If
    Cells(i, 2) = LTrim(Cells(i, 2))
    Next i
    i = Empty: Set Reg = Nothing
End Sub

 

[yelgecak]

Murat Hocam çok güzel bir çalışma. Sitede buna benzer çalışmalar var inceledim kelimeyi ayırmayı yapabildim. Ama benim isdediğim bi türlü beceremedim siteyide didik didik ettim yapamadım. İstediğim Sayfa1 de "HatNo/Adı:1/01" arayıp bulacak o cümleyi sayfa2 ye yazacak daha sonra "HatNo/Adı:2/02" yi bulacak bi alt satıra yazak daha sonra "HatNo/Adı:3/03" bulacak sayfa2 ye yazacak böyle 12 ye kadar devam edecek hocam. Sayfa2 ye attıktan sonra zaten kelimeyi ayırabiliyorum. ama sayfa1 den hep aynı hücrede olmadığı için sayfa2 ye atamadım. Şimdi Find diye bi komut gördüm onu araştırıyorum hocam. Yardım ederseniz sevinirim hocam, Ham dosyayıda ekliyorum. ben sayfa1 deki verileri kapalı dosyadan veri al olarak çekiyorum.

 

[yelgecak]

Kısaca istediğim hocam

Sayfa1 de bul Sayfa2 A1 e yapıştır, daha sonra Murat hocamın kodunu kullanacağım.

 

[Murat OSMA]

Dediğiniz gibi Find komutunu ve Like komutunu araştırın. Yapamazsanız yardımcı olurum...

 

[yelgecak]

sağolun hocam araştırıyorum

 

[tahsinanarat]

Başka bir altarnatif

dolu hücreler değişik kolonlarda olabilir, ancak hepsinin düzeninin aynı olması gerekir yani "Hat No/Adı:1/01 " ile başlıyor olmalı ki ilk boşluktan sonra 13 karakter sonrasını alıp Tarih* ile başlayanların Tarih ve sonrasını atıp geriye sizin istediğiniz kelimeler kalmaktadır. Yazım düzeni yukarıda anlattığımdan farklı ise işe yaramaz.

 

[yelgecak]

Hocam araştırmam sonucu aşağıdaki kodlarla işimi hallettim ama kodları çok uzun yazdım kısaltmanın bi yolu varmı.

Private Sub userform_initialize()

Sheets("Sayfa1").Select
Cells.Find("Hat No/Adı:1/01").Select
Selection.Copy
Sheets("Sayfa3").Select
Range("a1").Select
ActiveSheet.Paste

Sheets("Sayfa1").Select
Cells.Find("Hat No/Adı:2/02").Select
Selection.Copy
Sheets("Sayfa3").Select
Range("a2").Select
ActiveSheet.Paste

Sheets("Sayfa1").Select
Cells.Find("Hat No/Adı:3/03").Select
Selection.Copy
Sheets("Sayfa3").Select
Range("a3").Select
ActiveSheet.Paste


Böyle Hat No/Adı:12/12 ye kadar uzuyor kodlar.

Bu kodlardan sonrada sizin vermiş olduğunuz kodları uyguluyorum.

 

[Murat OSMA]

Sn. tahsinararat'ın sözlerine katılıyorum. Alınan verilerin birbiri ile aynı olması gerekir...
Aynı olmazsa ve ilk verdiğiniz satırlar ile aynı olmazsa; kodlar doğru sonucu vermezler..


Sn. yelgecak, diğer sayfaya kopyalama ile ilgili dilerseniz şu kodları kullanın;

Sub Emre()
    Dim Evn As Range
        Set Evn = Sayfa1.Range("A1:AB500").Find("HAT NO", , , xlPart)
            If Not Evn Is Nothing Then
                Adres = Evn.Address
            Do
               Set Evn = Sayfa1.Range("A1:AB500").FindNext(Evn)
               Evn.Copy Sayfa2.Range("A65536").End(3)(2, 1)
            Loop Until Adres = Evn.Address
            End If
            Sayfa2.Select
    Set Evn = Nothing
End Sub

 

[Murat OSMA]

Şu kodları olduğu gibi Module yapıştırıp bir deneyiniz;

Sub Emre()
    Dim Evn As Range
    Sayfa2.Cells.ClearContents
        Set Evn = Sayfa1.Range("A1:AB500").Find("HAT NO", , , xlPart)
            If Not Evn Is Nothing Then
                Adres = Evn.Address
            Do
               Set Evn = Sayfa1.Range("A1:AB500").FindNext(Evn)
               Evn.Copy Sayfa2.Range("A65536").End(3)(2, 1)
            Loop Until Adres = Evn.Address
            End If
            Sayfa2.Select
    Call Murat
    Set Evn = Nothing
End Sub


Sub Murat()
    Dim Reg As Object
    Dim i As Integer
    For i = 2 To Range("A65536").End(3).Row
        Cells(i, 1) = Replace(Replace(Cells(i, 1), " ", "", 1, 1), "    ", "", 1, 1)
    Set Reg = CreateObject("VBScript.RegExp")
    Reg.Global = True
    Reg.Pattern = "([a-zA-Z\s\ç\Ç\ö\Ö\ş\Ş\ı\İ\ğ\Ğ\ü\Ü]*)\s\w?\S+\ " '
    Set Say = Reg.Execute(Cells(i, 1))
        If Say.Count > 0 Then
            Cells(i, 2) = Reg.Execute(Cells(i, 1)).Item(0)
        End If
    Cells(i, 2) = LTrim(Cells(i, 2))
    Next i
    i = Empty: Set Reg = Nothing
End Sub

 

[tahsinanarat]

Dosyanız ekte

ben 9 nolu mesajımı gönderene kadar önceki yazışmaları görmemiştim, istediğinizi yapmaya çalıştığım dosyanızı ekte gönderiyorum, sayfa1 de b1 hücresine aradığınız kriteri yazarak (örn. tarih) enterlıyorsunuz, içerisinde tarih geçen bütün satırlar süzelüyor, süzülenleri aktar butonuna bastığınızda ise istediğiniz kelimeleri b sutununda almış oluyorsunuz.

 

[yelgecak]

bende öyle cevap bekliyordum. kusura bakmayın 2. sayfayı görmedim yeniledikçe 1. sayfa geliyormuş fark etmedim kusura bakmayın tekrardan özür dilerim.

 

[Murat OSMA]

Sonuç nedir ?

 

[tahsinanarat]

Sonuç: işi görülmüş anlaşılan

 

[Murat OSMA]

Bakalım bir cevap gelecek mi ? :dusun:

 

[yelgecak]

hocam bitince dosyayı ekleyeceğim. Baya uğraştım sizin sayenizde bi şeyler yapmaya çalıştık. Teşekkürler

 

[Murat OSMA]

Dosyayı eklemeenize gerek yok. Sn. tahsinanarat'ın ve benim önerdiğim kodlar işinize yaradı mı yaramadı mı ? Bunu belirtseniz kâfi..