Makro İle Aynı Sayıları Değiştirmek

[ormann]

Günaydın;
Ekli örnek dosyada liste sayfasında A2:A1500 hücre aralığında herhangi bir hücrede herhangi bir sayıyı değiştirdiğimde (örneğin bir hücrede 10 sayısını değiştirip yerine 150 sayısını yazdığımda A2:A1500 hücre aralığında kaç tane 10 sayısı varsa bunlar makro ile otomatik olarak 150 sayısına dönüşecek .Yardımcı olur mu sunuz.Biraz zor gibi gözüküyor .Umarım çözüm yolu vardır.

http://dosya.co/az7j1c8nwmha/Örnek.xlsm.html

 

[Korhan Ayhan]

Merhaba,

Çalışmanızın "BuÇalışmaKitabı" bölümüne aşağıdaki kodu uygulayın.

Dim Eski_Veri As Variant

Private Sub Worksheet_Activate()
    Cells(1, Columns.Count).Select
    Range("A2").Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Column = 1 And Target.Row > 1 Then
        Onay = MsgBox("Sütundaki tüm " & Eski_Veri & " değerleri " & Target.Value & " olarak değiştirilecektir !" & _
                       Chr(10) & Chr(10) & "Onaylıyor musunuz ?", vbCritical + vbYesNo)
        If Onay = vbNo Then GoTo 10
        Application.EnableEvents = False
        Set Bul = Range("A2:A1500").Find(Eski_Veri, , , xlWhole)
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                Bul.Value = Target.Value
                Set Bul = Range("A2:A1500").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
        Application.EnableEvents = True
    End If
                
10
    If Target.Column > 10 And Target.Column < 13 Then
        Cells(Target.Row, "M") = WorksheetFunction.Round(((Range("k" & Target.Row) / 2) ^ 2 * 3.1415 * Range("l" & Target.Row)) / 10000, 3) * 1
    End If
    
    If Target.Column = 3 And Target.Row > 1 Then
        For Each alan In Sheets("Yüzde").Range("b4:b16")
            If Target.Value = alan.Value Then
                say = say + 1
                hacim = Sheets("Yüzde").Range("c" & alan.Row).Value
            End If
        Next
        If say > 0 Then
            Range("d" & Target.Row).Value = hacim
        Else
            MsgBox "Bulunamadı"
            Range("d" & Target.Row).Value = ""
        End If
    End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("A2:m1500")) Is Nothing Then
        Range("a" & Target.Row & ":m" & Target.Row).Copy Range("a65536").End(3)(2, 1)
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    Eski_Veri = Target.Value
End Sub

Dosyanızı kayıt edin ve kapatıp açın. Sonra "A" sütununda işlem yapmayı deneyin.

 

[ormann]

Korhan bey çok teşekkür ederim.Tam istediğim şekilde çalışıyor.Fakat satır silip eklediğimde hata veriyor.Bilgisayarı kasıyor

 

[Korhan Ayhan]

Üstteki mesajımda ki kodu revize ettim. Tekrar deneyiniz.

 

[ormann]

Korhan bey çok teşekkür ederim.