• DİKKAT

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

Cümlenin arasında geçen kelimeyi almak

Y

yelgecak

Katılım
24 Haziran 2006
Mesajlar
95
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
 
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))
 
Ekli dosyayı inceleyiniz

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

Ekli dosyalar

Şu kodları bir deneyiniz;

Kod: 
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
 

Ekli dosyalar

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.
 

Ekli dosyalar

Kısaca istediğim hocam

Sayfa1 de bul Sayfa2 A1 e yapıştır, daha sonra Murat hocamın kodunu kullanacağım.
 
Dediğiniz gibi Find komutunu ve Like komutunu araştırın. Yapamazsanız yardımcı olurum...
 
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.
 

Ekli dosyalar

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.
 
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;
Kod: 
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
 
Şu kodları olduğu gibi Module yapıştırıp bir deneyiniz;

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

Ekli dosyalar

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.
 
:) Bakalım bir cevap gelecek mi ? :dusun:
 
hocam bitince dosyayı ekleyeceğim. Baya uğraştım sizin sayenizde bi şeyler yapmaya çalıştık. Teşekkürler
 
Dosyayı eklemeenize gerek yok. Sn. tahsinanarat'ın ve benim önerdiğim kodlar işinize yaradı mı yaramadı mı ? Bunu belirtseniz kâfi..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst