metin içerisinde düşeyara ile istenilen kelimeyi buldurma

Katılım
18 Ağustos 2015
Mesajlar
4
Excel Vers. ve Dili
excel 2010
Merhaba,
Elimde bir liste var bu listenin hücrelerinin içerisindeki cümlelerin içerisinde saha kodları bulunmakta bu saha kodlarını elimdeki saha kodu listesini kontrol ettirerek boş bir hücreye yazdırmak istiyorum.

"01/2015 ART-EDİZ 33ART193 KMT FAT. ÖD." hücrelerdeki metinler bu şekilde

elimdeki saha kodu listesi de
33ART193
23FTR192
41ANT051 gibi şimdi düşeyara gibi bir fonksiyon ile listedeki verileri cümle içerisinde sorgulatarak varsa cümle içerisindeki örneğin 33ART193'ü alıp boş bir hücreye yazdırmak istiyorum.

konu hakkında yardımlarınızı bekliyorum. İyi çalışmalar. Saygılar...
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Boş bir sayfada;

A1 hücresine 33ART193 yazın.

"F" sütununda ise bahsettiğiniz uzun metinler olsun. ("01/2015 ART-EDİZ 33ART193 KMT FAT. ÖD.")

B1 hücresine aşağıdaki formülü uygulayın.

Kod:
=EĞERSAY(F:F;"*"&A1&"*")
 
Katılım
18 Ağustos 2015
Mesajlar
4
Excel Vers. ve Dili
excel 2010
ben bu uzun saha kodları listesinin olduğu listeyi kullanarak o metinin içerisindeki saha kodunu süzüp bir yere yazdırmak istiyorum. mesela saha kodu listesi 1 sayfada bu uzun metinler 2 sayfada birinci uzun metin hücresindeki saha kodunu sayfa birden kontrol edecek bulursa sayfa 2 deki hücrenin yanına metnin içersinde karşılaştırdığı saha kodunu mesela 33art193 ü yazacak. Bu şekilde yapmak istiyorum. Şimdiden teşekkürler
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Örnek dosyanızı paylaşım sitelerine ekleyip linki foruma ekleyiniz.

Ayrıca dosyanız içinde görmek istediğiniz sonucu da lütfen belirtin.
 
Katılım
20 Şubat 2012
Mesajlar
242
Excel Vers. ve Dili
office2007 Türkçe
Deneyin

01/2015 ART-EDİZ 33ART193 KMT FAT. ÖD. =KelimeAl(A1;3;" ")

Fonksiyonu :

Function KelimeAl(HÜCRENİZ, KAÇINCIKELİME, Ayraç) As String

Dim Hücreseç As String, Boşluk As String
Dim ElemanSay As Integer, i As Integer

Hücreseç = HÜCRENİZ

If Ayraç = Chr(32) Then Hücreseç = Application.Trim(Hücreseç)


If Right(Hücreseç, 1) <> Ayraç Then Hücreseç = Hücreseç & Ayraç


ElemanSay = 0
Boşluk = ""

For i = 1 To Len(Hücreseç)
If Mid(Hücreseç, i, 1) = Ayraç Then
ElemanSay = ElemanSay + 1
If ElemanSay = KAÇINCIKELİME Then
'
KelimeAl = Boşluk
Exit Function
Else
Boşluk = ""
End If
Else
Boşluk = Boşluk & Mid(Hücreseç, i, 1)
End If
Next i
KelimeAl = ""
End Function
 
Katılım
23 Eylül 2013
Mesajlar
1,348
Excel Vers. ve Dili
Excel 2007 İngilizce -
Excel 2010 Türkçe -
Excel 2013 Türkçe -
Merhabalar,
Formül ile alternatif;
Varsayımlar üzerinden gidelim.

  • A1:A5 aralığında listeniz,
  • B1:B3 aralığında saha kodlarınız,
girişlerini yaparak deneyiniz.
Kod:
=İNDİS(B$1:B$3;KAÇINCI(1;1-EHATA(MBUL(B$1:B$3;A1));))
[COLOR="Blue"]Formül dizi formülüdür.CTRL+SHIFT+ENTER ile tamamlayınız.[/COLOR]
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
#6 nolu mesajda önerilen formülü deneyiniz.
 

downsoon

Altın Üye
Katılım
9 Kasım 2008
Mesajlar
53
Excel Vers. ve Dili
Office 2007 TR
Böyle bir makroya ihtiyacım var, yalnız ek olarak şuna ihtiyacım var.
1- D sütununda olanları A sütununda içeriyorsa (burada şu sıkıntı da var23 ü içeren 2 yi de içeriyor ama 23 ü almasını istiyorum) E sütununa yazması
2- F sütununda olanları A sütununda içeriyorsa G sütununa yazması.

Denedim ama makro bilgim az olduğu için uyarlayamadım, chatgpt üzerinden kodu güncellettim. Şu anda tam istediğim gibi çalışıyor.
 

Ekli dosyalar

Son düzenleme:

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Umarım doğru anlamışımdır.

Deneyiniz.

C++:
Sub Bul_Listele()
    Dim X As Long, Y As Long, Search_Text As Integer
  
    Application.ScreenUpdating = False
  
    Range("E:E,G:G").ClearContents
  
    For X = 1 To Cells(Rows.Count, "A").End(3).Row
        If Cells(X, "A") <> "" Then
            For Y = 1 To Cells(Rows.Count, "D").End(3).Row
                If Cells(Y, "D") <> "" Then
                    If InStr(1, Cells(X, "A"), Cells(Y, "D")) > 0 Then
                        Cells(X, "E") = Cells(Y, "D")
                        Exit For
                    End If
                End If
            Next
      
            For Y = 1 To Cells(Rows.Count, "F").End(3).Row
                If Cells(Y, "F") <> "" Then
                    On Error Resume Next
                    Search_Text = 0
                    Search_Text = WorksheetFunction.Search(Cells(Y, "F"), Cells(X, "A"))
                    On Error GoTo 0
                    If Search_Text > 0 Then
                        Cells(X, "G") = Cells(Y, "F")
                        Exit For
                    End If
                End If
            Next
        End If
    Next

    Columns("A:G").AutoFit

    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 

downsoon

Altın Üye
Katılım
9 Kasım 2008
Mesajlar
53
Excel Vers. ve Dili
Office 2007 TR
Alttaki kod sorunsuz çalışti. İlginize teşekkürler


Application.ScreenUpdating = False
On Error Resume Next
Sheets("Sayfa1").Range("E1:E65536").ClearContents
Set s1 = ThisWorkbook.Worksheets("Sayfa1")
sonsatir = s1.Range("A65536").End(xlUp).Row
sonsatir1 = s1.Range("b65536").End(xlUp).Row
For i = sonsatir To 1 Step -1
veri = UCase(Cells(i, 1))
For k = 1 To sonsatir1
If s1.Cells(k, 2) <> "" Then
bulunacak = InStr(1, veri, UCase(s1.Cells(k, 2)))
If bulunacak > 0 Then Cells(i, 3) = s1.Cells(k, 2)
End If
Next k
Next i
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Sayfa1").Range("E1:E65536").ClearContents
Set s1 = ThisWorkbook.Worksheets("Sayfa1")
sonsatir = s1.Range("A65536").End(xlUp).Row
sonsatir1 = s1.Range("D65536").End(xlUp).Row
sonsatir2 = s1.Range("B65536").End(xlUp).Row
For i = sonsatir To 1 Step -1
veri = UCase(Cells(i, 1))
For k = 1 To sonsatir1
If s1.Cells(k, 4) <> "" Then
bulunacak = InStr(1, CStr(veri), UCase(CStr(s1.Cells(k, 4))))
If bulunacak > 0 Then Cells(i, 5) = s1.Cells(k, 4)
End If
Next k
For k = 1 To sonsatir2
If s1.Cells(k, 2) <> "" Then
bulunacak = InStr(1, veri, UCase(s1.Cells(k, 2)))
If bulunacak > 0 Then Cells(i, 3) = s1.Cells(k, 2)
End If
Next k
Next i
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Sayfa1").Range("G1:G65536").ClearContents
Set s1 = ThisWorkbook.Worksheets("Sayfa1")
sonsatir = s1.Range("A65536").End(xlUp).Row
sonsatir1 = s1.Range("F65536").End(xlUp).Row
sonsatir2 = s1.Range("B65536").End(xlUp).Row
For i = sonsatir To 1 Step -1
veri = UCase(Cells(i, 1))
For k = 1 To sonsatir1
If s1.Cells(k, 6) <> "" Then
bulunacak = InStr(1, veri, UCase(s1.Cells(k, 6)))
If bulunacak > 0 Then Cells(i, 7) = s1.Cells(k, 6)
End If
Next k
For k = 1 To sonsatir2
If s1.Cells(k, 2) <> "" Then
bulunacak = InStr(1, veri, UCase(s1.Cells(k, 2)))
If bulunacak > 0 Then Cells(i, 3) = s1.Cells(k, 2)
End If
Next k
Next i
End Sub
 
Son düzenleme:

downsoon

Altın Üye
Katılım
9 Kasım 2008
Mesajlar
53
Excel Vers. ve Dili
Office 2007 TR
Tek sıkıntısı Türkçe karakterlerde sorun çıkarıyor. Örneğin Mahkeme ile MAHKEME yi aynı diyor buluyor ama Vergi ile VERGİ yi eşleştiremiyor. Yani Türkçe karakterin büyük küçük harf olması formülü bozuyor
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bu yorumunuz hangi kod içindi?
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,327
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ben önerdiğim kodu güncelledim. Tekrar deneyiniz.
 

downsoon

Altın Üye
Katılım
9 Kasım 2008
Mesajlar
53
Excel Vers. ve Dili
Office 2007 TR
Süper, elinize sağlık. Sizin kod bendekinden çok daha hızlı çalıştı.

Sadece aynı sıkıntı devam ediyor. Türkçe karakter büyük küçük harf duyarlılığı var
 
Üst