Değerleri cümle içinde aratmak

[adigeturklim]

Merhaba,

Ekli dosyada örnek verileri yazdım. Sayfa1 de bulunan standart kodları sayfa2 deki açıklamaların içinde aratıp yanına kodu yazdırmak gibi birşey yapabilir miyiz.

Teşekkür ederim.

 

[adigeturklim]

Selamlar, konu hakkında yardımcı olabilecek varmıdır

 

[Asri]

Makrolu çözüm:
Kodlar satırın başında yada sonunda ise sonuç verecektir.
Arada boşluk olup olmaması önemli değil.

Sub kodbul()
   Set sh1 = Sheets("Sayfa1")
   Set sh2 = Sheets("Sayfa2")
  
   sonsatirsh1 = sh1.Cells(sh1.Rows.Count, "B").End(3).Row
   sonsatirsh2 = sh2.Cells(sh2.Rows.Count, "B").End(3).Row
  
   sh2.Range("C3:C" & sonsatirsh2).ClearContents
  
   For k = 5 To sonsatirsh1
        On Error GoTo son
        sh1kod = sh1.Cells(k, "B").Value
        For i = 3 To sonsatirsh1
          veri = Trim(sh2.Cells(i, "B").Value)
          veris = veri
          soldan = ""
          For j = 1 To Len(veri)
            sayi = Mid(veris, j, 1)
            If sayimi(sayi) Then
               soldan = soldan & sayi
            Else
               Exit For
            End If
          Next j
          
          veris = veri
          sagdan = ""
          For j = Len(veri) To 1 Step -1
            sayi = Mid(veris, j, 1)
            If sayimi(sayi) Then
               sagdan = sayi & sagdan
            Else
               Exit For
            End If
          Next j
          If soldan = sh1kod Or sagdan = sh1kod And sh1kod <> "" Then
             sh2.Cells(i, "C").Value = sh1kod
          End If
          
        Next i
son:
    Next k
   On Error GoTo 0
End Sub

Function sayimi(sadecesayistr)
  liste = "0123456789"
  For k = 1 To Len(sadecesayistr)
    harf = Mid(sadecesayistr, k, 1)
    If InStr(liste, harf) = 0 Then
       sayimi = False
       Exit Function
    End If
  Next k
  sayimi = True
End Function

 

[adigeturklim]

Selamlar, sayın asri bazı sağlık sorunlarından dolayı cevabınıza dönüş yapamadım kusura bakmayın. Teşekkür ederim çalışmanız için. Kodlar cümlenin herhangi bir yerinde olabiliyor malesef. Bu durumda başka bir fonksiyon ile veya makro kodu ile çözüm bulabilir miyiz. Teşekkürler

 

[catalinastrap]

Merhaba;
eki kontrol edin.Daha önce bir arkadaşımız çözüm yapmıştı bu konu ile ilgili

 

[Haluk]

Ekli alternatifte "Regular Expressions" metodu kullanılmış olup; aranan kodlar cümlenin başında, arasında bir yerde veya sonunda olabilir..... yakalayıp, getirir.

.

 

[adigeturklim]

Sayın catalinasrap ve sayın Haluk, örnek dosyalarınız başarılı bir şekilde çalışıyor. Elinize sağlık Teşekkür ederim.

 

[adigeturklim]

Ekli alternatifte "Regular Expressions" metodu kullanılmış olup; aranan kodlar cümlenin başında, arasında bir yerde veya sonunda olabilir..... yakalayıp, getirir.

.

Selamlar Haluk bey, 2019 yılında sizden yardım almıştım ve hala bu tabloyu kullanıyorum . Mümkünse ve siz müsaitseniz bir ricam olacak. Kodu belli bir aralığı okuyacak şekilde nasıl düzenleyebilirim. Bütün stündaki satırları değilde mesela "G" stünunda 15.000 satır okuyacak şekilde. Sanırım kod aşağı doğru stünun tamamını okuyor bu sebeple sonuç almam epey uzun sürüyor. Kısacası biraz daha hızlı çalışması için bir yol arıyorum. Teşekkür ederim.


Sub Test()
' Haluk - 06/10/2019
' sa4truss@gmail.com
'
Dim NoB As Long
Dim regExp As Object
Dim myStr As String, i As Long
Dim Codes() As String

NoB = Sheets("Günlük Banka Extresi").Range("G" & Rows.Count).End(xlUp).Row
Sheets("Günlük Banka Extresi").Range("C5:C" & NoB) = ""

countCodes = Sheets("Mağaza Bilgileri").Range("D" & Rows.Count).End(xlUp).Row

For i = 5 To countCodes
ReDim Preserve Codes(j)
Codes(j) = Sheets("Mağaza Bilgileri").Range("D" & i).Text
j = j + 1
Next

Set regExp = CreateObject("VBScript.RegExp")

regExp.IgnoreCase = True
regExp.Global = True
regExp.Pattern = "(" & Join(Codes, "|") & ")"

For i = 2 To NoB
myStr = Sheets("Günlük Banka Extresi").Range("G" & i)
If regExp.Test(myStr) Then
Set objMatches = regExp.Execute(myStr)
Range("C" & i) = objMatches.Item(0).Submatches.Item(0)
End If
Next

Set regExp = Nothing
End Sub

 

[Haluk]

NoB = 15000

böyle deneyin ...

.

 

[adigeturklim]

Teşekkür ederim deniyorum hemen

 

[adigeturklim]

Haluk bey test ettim. NoB) = "" ve NoB) = 15000 olarak ikisi de 15 binlik Excel satırını 12 dakikada bitiriyor. (i7 işlemci ile )

Teşekkürler, zaman ayırdınız..

 

[Haluk]

NoB değişkeni zaten sütunun en son dolu hücresine kadar çalışır.

Eğer en son dolu satır no'su 15000 ise o değeri hesaplayıp bulur ve onu kullanır.

Sorunuzdan benim anladığım, örneğin 100.000 adet satır var, siz sadece 15.000'de çalışsın istiyorsunuz diye anlamıştım.....

.

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Birim_Kodu_Bul()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double
    Dim Kelime As Variant, Y As Integer, Say As Long
  
    Zaman = Timer
  
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
  
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
  
    Veri = S1.Range("B5:B" & Son).Value2
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Not IsError(Veri(X, 1)) Then
            If Veri(X, 1) <> "" Then Dizi.Add CStr(Veri(X, 1)), CStr(Veri(X, 1))
        End If
    Next
  
    Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
  
    Veri = S2.Range("B3:B" & Son).Value2
  
    ReDim Liste(1 To S2.Rows.Count, 1 To 1)
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Kelime = Split(Veri(X, 1), " ")
            Say = Say + 1
            For Y = LBound(Kelime) To UBound(Kelime)
                If Dizi.Exists(Kelime(Y)) Then
                    Liste(Say, 1) = Dizi.Item(Kelime(Y))
                    Exit For
                End If
            Next
        End If
    Next
  
    If Say > 0 Then
        With S2.Range("C3")
            .Resize(S2.Rows.Count - 2).ClearContents
            .Resize(S2.Rows.Count - 2).NumberFormat = "@"
            .Resize(Say) = Liste
        End With
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    End If

    Erase Liste

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

 

[adigeturklim]

Merhaba Korhan bey, gönderdiğiniz alternatif kodu deniyorum fakat bu sarı alandaki hatayı veriyor

 

[Korhan Ayhan]

Mouse ile Veri(X, 1) yazan yerin üzerine gelip biraz bekleyin. Size aldığı değeri gösterecek. Onu paylaşırsanız düzeltmeye çalışırım.

Ya da hata veren dosyanızı paylaşın üzerinden kontrol edelim.

 

[adigeturklim]

Korhan bey bu şekilde bir değer veriyor

 

[Korhan Ayhan]

Sayfa1 birim kodları sütununda aralarda boş hücreler var sanırım.

Üstte ki mesajimdaki koda küçük bir ekleme yaptım.Tekrar deneyiniz