Hücre içinde otomatik değiştirme

[Jeeday]

İstediğim şey dosya içindedir...

Teşekkürler

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu ilgili sayfanın kod bölümüne uygulayıp denermisiniz. Siz A sütununda link girdikçe verdiğiniz formata göre otomatik olarak düzelecektir.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target <> "" Then
    Application.EnableEvents = False
    If InStr(1, Target, "php?s") > 0 Then
    Target = "[URL]http://www…………..com/index.php?act=book&CODE=07&rid[/URL]=" & Right(Replace(Target, ")", ""), 5)
    End If
    Application.EnableEvents = True
    End If
End Sub

 

[Jeeday]

Harikasın!!!

 

[Jeeday]

Hata çıktı...

linki yazınca kendisi otomatik düzeltiyo. buraya kadar OK!. fakat düzelmiş hücreyi alıp başka bir sheet'e kopyaladığımda Run-Time error '13': type mismatch hatası veriyor...Debug'a tıkladığımda If Target <> "" Then satırı SARI renkle boyanmış gözüküyor... Rica etsem durumu inceleyebilir misiniz?

 

[Korhan Ayhan]

Selamlar,

Ben önermiş olduğum kod eklediğiniz örnek dosya üzerinde denedim ve hata ile karşılaşmadım. Eğer hata aldığınız dosyayı eklerseniz soruna neyin sebep olduğunu tesbit edebiliriz.

 

[Jeeday]

Dosyayı yolladım

 

[Korhan Ayhan]

Selamlar,

Daha önceki önermiş olduğum kod hücre içine veri girişi yapıldığında yada tek hücre kopyalayarak veri girişi yapıldığında sağlıklı çalışır. Siz birden fazla alanı kopyala yapıştır yöntemi ile sayfaya aktarıp kodun hatalı linki düzeltmesini istiyorsanız aşağıdaki kodu kullanabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Hücre As Range
    
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    
    If Target.Cells.Count = 1 Then
        If Target <> "" Then
        Application.EnableEvents = False
            If InStr(1, Target, "php?s") > 0 Then
                Target = "[URL]http://www…………..com/index.php?act=book&CODE=07&rid[/URL]=" & Right(Replace(Target, ")", ""), 5)
            End If
        Application.EnableEvents = True
        End If
    
    Else
    
        For Each Hücre In Range("A" & Selection.Row & ":A" & Selection.Row + Selection.Rows.Count - 1)
            If Hücre.Column = 1 Then
            Application.EnableEvents = False
                If InStr(1, Hücre.Value, "php?s") > 0 Then
                    Hücre.Value = "[URL]http://www…………..com/index.php?act=book&CODE=07&rid[/URL]=" & Right(Replace(Hücre.Value, ")", ""), 5)
                End If
            Application.EnableEvents = True
            End If
        Next
    
    End If
End Sub

 

[Jeeday]

ilk haliyle link istediğim gibi değişiyor orda sorun yok. ama düzeltilmiş linkin bulunduğu hücreyi içeren hücre topluluğunu seçip başka bir sayfaya kopyaladığımda, kopyalama işlemini eksiksiz yapıyor ama hep o hata penceresi çıkıyor... End ve Debug seçenekleri çıkıyor... End seçince excele geri dönüyor ama işlem eksiksiz hallolmuş oluyor... O hata penceresi neden çıkıyor işte sorum o asıl