9EL 996 471-001 yazılı hücreyi 9el996471001 olarak arama

[tahsinanarat]

Örnek dosyamda 9el 996... (küçük harflerle) şeklinde yazıp arama yaptırabiliyor ve bulduklarımı sayfa2 ye aktarabiliyorum. Ancak ben, A Sutununda yazılı bulunan verilerden 9EL 996 471-001 yazılı hücreyi arada boşluk ve "-" yokmuş gibi "9el996471001" olarak arama nasıl yaptırabiliriz
Not. büyük küçük harf ayrımı olmadan da arama yaptırabilirsek daha güzel olur. Teşekkürler

 

[Ferhat Pazarçevirdi]

Mevcut kodlarınızın yerine, aşağıdakileri kullanınız.

Private Sub CommandButton1_Click()
Dim sh2 As Worksheet
Dim aranan As String
Dim i As Integer, j As Integer, son As Integer
Set sh2 = Sheets("Sayfa2")
sh2.Range("A2:C5000").ClearContents
aranan = UCase(Replace(TextBox1.Value, "ı", "I"))
For i = 2 To Cells(65536, 1).End(xlUp).Row
    If aranan Like Duzeltme(Cells(i, 1)) Or aranan Like Cells(i, 1) Then
        son = sh2.Cells(65536, 1).End(xlUp).Row + 1
        For j = 1 To 3
            sh2.Cells(son, j) = Cells(i, j)
        Next j
    End If
Next i
End Sub
[COLOR=green]'-----------------------[/COLOR]
Function Duzeltme(kelime As String) As String
With CreateObject("VBScript.RegExp")
    .Pattern = "[^\w]"
    .Global = True
    If .Test(kelime) Then Duzeltme = .Replace(kelime, "")
End With
End Function

 

[tahsinanarat]

Denedim ama herhangi bir aktarma yapmadı, örnek dosya üzerinde düzenleyin gönderirseniz sevinirim. Saygılar

 

[Ferhat Pazarçevirdi]

İnceleyiniz.

 

[tahsinanarat]

Bu ne hız efendim, teşekkür ederim.

 

[tahsinanarat]

Sn. Ferhat bey kelime olarak istediğim sutunda arama yapamıyorum, yani öncekinin esnekliğini bozmadan yaptığınız aramayı yaptırabilirsek harika olur.

 

[Ferhat Pazarçevirdi]

Ben de diyorum; "bu Textbox2 ne işe yarıyor" diye .... İlahi

O zaman; tüm kodlarınızı silin ve aşağıdakilerini kopyalayın.

Private Sub CommandButton1_Click()
If TextBox2 = "a" Then
    Call A_Sutununda_Ara
Else
    Diger_Sutunlarda_Ara
End If
End Sub
'---------------------------
Function Duzeltme(kelime As String) As String
With CreateObject("VBScript.RegExp")
    .Pattern = "[^\w]"
    .Global = True
    If .Test(kelime) Then Duzeltme = .Replace(kelime, "")
End With
End Function
'----------------------
Sub A_Sutununda_Ara()
Dim sh2 As Worksheet
Dim aranan As String
Dim i As Integer, j As Integer, son As Integer
Set sh2 = Sheets("Sayfa2")
sh2.Range("A2:C5000").ClearContents
aranan = UCase(Replace(TextBox1.Value, "ı", "I"))
For i = 2 To Cells(65536, 1).End(xlUp).Row
    If aranan Like Duzeltme(Cells(i, 1)) Or aranan Like Cells(i, 1) Then
        son = sh2.Cells(65536, 1).End(xlUp).Row + 1
        For j = 1 To 3
            sh2.Cells(son, j) = Cells(i, j)
        Next j
    End If
Next i
sh2.Select
Set sh2 = Nothing
End Sub
'---------------------------
Sub Diger_Sutunlarda_Ara()
Dim i As Long, sat As Long
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Sheets("Sayfa2").Range("A2:Z65536").ClearContents
sat = 2
For i = 1 To Cells(65536, TextBox2.Value).End(xlUp).Row
    If LCase(Replace(Replace(Cells(i, TextBox2.Value).Value, "I", "ı"), "ı", "ı")) Like _
   "*" & TextBox1.Value & "*" Then
        adr1 = Range(Cells(i, "A"), Cells(i, "Z")).Address
        adr2 = Range(Cells(sat, "A"), Cells(sat, "Z")).Address
        Sheets("Sayfa2").Range(adr2).Value = Range(adr1).Value
        sat = sat + 1
        Adet = sat + 1 - 3
    End If
Next
Application.ScreenUpdating = True
    MsgBox " Aktarılan sayfasına " & Adet & " Adet Kayıt Aktarılmıştır..tomson!!"
End Sub

 

[tahsinanarat]

Diğer sutunlarda ara, kod tamam, ancak düzeltme fonksiyonunu buraya uyarlayamadık, yani boşluk olmadan yazdığımızda "9EL 996 471-001 yazılı hücreyi 9el996471001 olarak arama" yapmıyor.
Eğer düzeltme fonksiyonunu buraya uyarlayabilirseniz benim işimi görür.

 

[Ferhat Pazarçevirdi]

Sayfa üzerindeki Textbox2'nin görevi nedir?

 

[tahsinanarat]

hangi sutunda arama yapacağımızı belirlemek için, örn. k yazdığımızda k sutununda arama yaptıracağımızı belirlemek için

 

[Ferhat Pazarçevirdi]

O halde size verdiğim kodlar, işinizi görüyordur. Çünkü, sadece Textbox2'ye "A" girdiğiniz zaman, özel arama prosedürü çalışıyor. Textbox2'ye "A" haricinde ne girerseniz girin, sizin eski prosedürünüz çalışıyor.

Sizin istediğiniz de bu değil miydi?

 

[tahsinanarat]

orjinal kodlar;
Private Sub CommandButton1_Click()
Dim i As Long, sat As Long
Sheets("Liste").Select
Application.ScreenUpdating = False
Sheets("Aktarılan").Range("A2:Z65536").ClearContents
sat = 2
For i = 1 To Cells(65536, TextBox2.Value).End(xlUp).Row
If LCase(Replace(Replace(Cells(i, TextBox2.Value).Value, "I", "ı"), "ı", "ı")) Like _
"*" & TextBox1.Value & "*" Then
adr1 = Range(Cells(i, "A"), Cells(i, "Z")).Address
adr2 = Range(Cells(sat, "A"), Cells(sat, "Z")).Address
Sheets("Aktarılan").Range(adr2).Value = Range(adr1).Value
sat = sat + 1
Adet = sat + 1 - 3
End If
Next
Application.ScreenUpdating = True
MsgBox " Aktarılan sayfasına " & Adet & " Adet Kayıt Aktarılmıştır..tomson!!"
Application.Run "'Resimekle.XLS'!Makro4"
End Sub

şeklinde olduğunda herhangi bir problem yok.
Bende devamlı uğraşıyorum, sanıyorum boşluk olmadan arama yaptırdığımız şekle getirsek bile boşluk verip yazdığımız bir kelimeye bulamayacağı kanısına vardım. Yani devamlı arama yapacağımız kelime veya kelimeler arasında herhangi bir boşluk vermeden girmemiz gerekeceğini sandığımdan, bu uğraşımdan vaz geçiyor, sizleri de boşuna yordum, emeğinize çok teşekkür ederim. Saygılar sunarım. sağolun sn. Ferhat Bey