• DİKKAT

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

Değerleri cümle içinde aratmak

adigeturklim

adigeturklim

Altın Üye
Katılım
24 Nisan 2009
Mesajlar
213
Excel Vers. ve Dili
Windows 10 Pro / Office 365
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.
 

Ekli dosyalar

Selamlar, konu hakkında yardımcı olabilecek varmıdır
 
Makrolu çözüm:
Kodlar satırın başında yada sonunda ise sonuç verecektir.
Arada boşluk olup olmaması önemli değil.

Kod: 
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
 
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
 
Merhaba;
eki kontrol edin.Daha önce bir arkadaşımız çözüm yapmıştı bu konu ile ilgili
 

Ekli dosyalar

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

.
 

Ekli dosyalar

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.
 
Haluk' Alıntı:
Ekli alternatifte "Regular Expressions" metodu kullanılmış olup; aranan kodlar cümlenin başında, arasında bir yerde veya sonunda olabilir..... yakalayıp, getirir.

.
Genişletmek için tıkla ...
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
 
NoB = 15000

böyle deneyin ...

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

.
 
Alternatif;

C++: 
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
 
Merhaba Korhan bey, gönderdiğiniz alternatif kodu deniyorum fakat bu sarı alandaki hatayı veriyor
230678
 
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.
 
Korhan bey bu şekilde bir değer veriyor
230680
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst