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

[Korhan Ayhan]

Önerdiğim koda küçük bir ekleme yaptım. Tekrar deneyiniz.

 

[downsoon]

Aynı durumda

Örneğin
Soldaki ALİAĞA İŞ MAHKEMESİ yazıyor. Sağda İş Mahkemesi var. İçerdiği halde türkçe karakterlerde büyük küçük harf duyarlılığı var.

 

[Korhan Ayhan]

Kodu tekrar revize ettim. Yeniden deneyiniz.

 

[downsoon]

Aynı şekilde, Türkçe Karakterli olursa hata veriyor

Örnek:
Arama Kurtarma ile ARAMA KURTARMA yı eşleştiriyor.
Ayrışma Kurtulma ile AYRIŞMA KURTULMA yı eşleştiremiyor. ı ve ş türkçe karakterleri içerince birinde küçük birinde büyük harfle yazışmışsa eşleştirmiyor

If InStr(1, ConvertTurkishChars(Cells(X, "A")), ConvertTurkishChars(Cells(Y, "D"))) > 0 Then
Search_Text = WorksheetFunction.Search(ConvertTurkishChars(Cells(Y, "F")), ConvertTurkishChars(Cells(X, "A")))

Bu 2 kodu kullandım ama faydası olmadı

 

[Korhan Ayhan]

Önerdiğim kodu D-F sütununlarında olabilecek boş hücrelerden dolayı tekrar revize ettim. Son halini tekrar deneyiniz.

Ek olarak paylaştığınız dosyaya önerdiğim kodu eklemişsiniz fakat butona tanımlamamışsınız. Bu sebeple eksik çalışıyor gibi görmüş olabilirsiniz.

 

[downsoon]

Aynen ya o kodu çalıştırmamışım

Son halini ekledim. Tam istediğim gibi çalışıyor

 

[downsoon]

Ufak düzenlemeler yaptım. Çalışıyor ama hata veriyor

Kod bu:
Sub Bul_Listele()
Sheets("FORMUL").Select
Columns("A:A").Select
Selection.ClearContents
Sheets("UETS").Select
Range("S4:X8").Select
Range("X8").Activate
ActiveWindow.SmallScroll ToRight:=-4
Range("O2:O9999").Select
Selection.Copy
Sheets("FORMUL").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("BELGENET").Select
Range("A1:A29999").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("FORMUL").Select
ActiveWindow.SmallScroll Down:=12
Range("A10000").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("a1").Activate
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, "B").End(3).Row
If Cells(Y, "B") <> "" Then
On Error Resume Next
Search_Text = 0
Search_Text = WorksheetFunction.Search(Cells(Y, "B"), Cells(X, "A"))
On Error GoTo 0
If Search_Text > 0 Then
Cells(X, "C") = Cells(Y, "B")
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

Hata satırım da If Cells(X, "A") <> "" Then

 

[Korhan Ayhan]

Örnek dosyayı görmek gerekir.

 

[downsoon]

Tablo bu şekilde . Aslında burada 3 adet düğmeye farklı makrolar atayarak işlemi sorunsuz tamamlayabildim. Amacım bunları tek makro kodu içinde çalıştırarak tek düğmeyle işi bitirebilmek

 

[Korhan Ayhan]

Bütün makrolarınız sorunsuz çalışıyorsa aşağıdaki gibi hepsini sırasıyla tek seferde çalıştırabilirsiniz.

Sub All_Macro_Run()
    Call Module9.ilkkopyala
    Call Module9.ListePaste
    Sayfa9.Bul_Listele
End Sub

 

[downsoon]

Elimdeki tabloya gerekli güncellemeleri yaptım, son makro kodunu da ekledim. Sorunsuz çalıştı. Teşekkürler Korhan Bey, elinize emeğinize sağlık