Makroyu bir defa çalıştırma

[moonty]

Merhabalar: Aşağıdaki gibi bir makro var. Göreceğiniz üzere sayfada C:AZZ arasındaki değerler eğer A2:B5000 arasında varsa A sütunun hizasındaki B sutununda bulunan değer ile değiştiriyor. Örneğin: A2:B5000 de AMA - FAKAT ve FAKAT - AMA değişim için alt alta listelenmiş. Normalde C2 hücresine AMA yazdığımda, FAKAT ile değiştirmesi lazım. Ancak makro önce AMA yı FAKAT yapıyor, sonra FAKAT'ı tekrar AMA yapıyor. Çünkü alt satırda kelimeler tam tersi verilmiş. Yani bir nevi döngü.
Bir kelimeyi değiştirdikten sonra aynı komut esnasında ikinci kez değiştirmesini nasıl önleriz. Bu döngüyü engellemek için ne yapılabilir acaba? Bilgisi olanlar yardımcı olursa sevinirim.
Tablo bu şekilde: https://imgyukle.com/i/EO0NZN
Makro da budur:

Sub BulDegistir()
Dim Lst, aln
Set Lst = Sheets("Örnek").Range("A2:B5000")
Set aln = Sheets("Örnek").Range("C:AZZ")
For Each hcr In Lst.Columns(1).Cells
aln.Replace what:=hcr.Value, replacement:=hcr.Offset(0, 1).Value
Next hcr
End Sub

 

[askm]

Aşağıdaki şekilde deneyin

Sub BulDegistir()
Dim Lst, aln
Set Lst = Sheets("Örnek").Range("A2:B5000")
Set aln = Sheets("Örnek").Range("C:AZZ")
For Each hcr In Lst.Columns(1).Cells
if hcr.Offset(0, 2).Value<>"X" then
       aln.Replace what:=hcr.Value, replacement:=hcr.Offset(0, 1).Value
       hcr.Offset(0, 2).Value="X"
end if
Next hcr
End Sub

 

[moonty]

malesef olmadı. C sütununda hücrelere X atıyor, değiştiriyor, ama yine ilk haline dönüyor. Yani önce bulup değiştiriyor sonra aşağıda tekrar aynı kelimeler sütun olarak yer değiştirdiği için bir kez daha değiştiriyor ve ilk haline dönüyor. Örnek dosya aşağıda.

https://dosya.co/yf08ml7oillv/deneme1.xlsm.html

 

[askm]

Aşağıdaki kodları deneyin.

Sub BulDegistir7()
Dim son As Long
Application.ScreenUpdating = False
son = Range("A" & Rows.Count).End(3).Row
For i = 2 To son
    If Cells(i, 3) = Empty Then
        Cells(i, 1).Replace what:=Cells(i, 1).Value, replacement:=Cells(i, 2).Value
        Cells(i, 3) = "X"
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamam...", vbInformation, "ASKM"
End Sub