Makro ile çoklu hücre eşitlemek

[Erkand]

Merhaba;


aşağıdaki kodları kullanarak sayfa1.B3 hücresini ile sayfa2.h28 hücrelerini birbirlerine eşitledim ve herhangibiri değiştiğinde diğeride değişiyor.Ben bunu çoklu yapmak istiyorum.
Örnek dosya üzerinden konuşursam;

aynı işlemi sayfa1.e3 ile sayfa2 n28 ve bi'kaç hücreye yapmak istiyorum.Dosyayı indirseniz rahatlıkla anlarsınız.Çoğul olarak yapmak için if döngülerini kullandım ama başarılı olamadım.
Şimdiden teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [B3]) Is Nothing Then Exit Sub
Sheets("Sayfa2").Cells(28, 8).Value = Target.Value
End Sub

ve

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [H28]) Is Nothing Then Exit Sub
Sheets("Sayfa1").Cells(3, 2).Value = Target.Value
End Sub

 

[Erkand]

Dosyayı indiren arkadaşlar görüş bildirirlerse sevinirim.

 

[leumruk]

Merhaba,
Aşağıdaki yöntemi kullanarak kendinize göre çoğaltın.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, [B3]) Is Nothing Then [Sayfa2!h28] = Target.Value
If Not Intersect(Target, [E3]) Is Nothing Then [Sayfa2!n28] = Target.Value
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, [h28]) Is Nothing Then [Sayfa1!b3] = Target.Value
If Not Intersect(Target, [n28]) Is Nothing Then [Sayfa1!e3] = Target.Value
End Sub

 

[Erkand]

Merhaba,
Aşağıdaki yöntemi kullanarak kendinize göre çoğaltın.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If [COLOR="Red"]Not [/COLOR]Intersect(Target, [B3]) Is Nothing Then
If [Sayfa2!h28] <> Target.Value Then
[Sayfa2!h28] = Target.Value
End If: End If

If [COLOR="red"]Not [/COLOR]Intersect(Target, [E3]) Is Nothing Then
If [Sayfa2!n28] <> Target.Value Then
[Sayfa2!n28] = Target.Value
End If: End If

End Sub

hocam bunu yapınca h28 ve n28 değerleri b3 değerinin aynısı oluyor.Benmi yanlış ekledim acaba.sayfa1,sayfa2 ve thisworkbook'a ekledim ama yinede aynı sonuç.

 

[leumruk]

Merhaba,
Ben de bir sıkıntı yok. Kodu biraz daha sadeleştirdim ve örnek dosya ekledim. Örnek dosyayı inceleyiniz.

 

[Erkand]

Merhaba,
Ben de bir sıkıntı yok. Kodu biraz daha sadeleştirdim ve örnek dosya ekledim. Örnek dosyayı inceleyiniz.

Hocam manuel olarak değiştirdiğimizde sorun yok ancak şöyle bir durum var.

ben standardı seç dediğimde n28 ile h28 aynı oluyor.Sizin verdiğiniz dosya da da aynı sorun mevcut.SAnırım o gözünüzden kaçtı.

 

[leumruk]

Hocam manuel olarak değiştirdiğimizde sorun yok ancak şöyle bir durum var.

ben standardı seç dediğimde n28 ile h28 aynı oluyor.Sizin verdiğiniz dosya da da aynı sorun mevcut.SAnırım o gözünüzden kaçtı.

Merhaba,
Sorun sizin dosyanızdaki diğer kodların veri alma biçiminden kaynaklanıyor. Verileri bütün halinde diğer satıra aktardığından sayfa kodları devreye girmiyordu. Veri almayı döngüye çevirince sorun düzeldi. Ekli dosyayı inceleyin.

Sub standart_sec()
Dim k As Range, sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
Set sh3 = Sheets("Sayfa3")
If sh2.Range("B16").Value = "" Then
    MsgBox "B16 Hücresinde değer yok." & vbLf & "B16 hücresindeki formül silinmiş olabilir. " _
    & "veya boşluk seçmiş olabilirsiniz" & vbLf & "Kayıt seçilmedi.", vbCritical, "UYARI"
    Exit Sub
End If
Set k = sh3.Range("B13:B1000").Find(sh2.Range("B16").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
[COLOR="Red"]For x = 2 To 11
    sh1.Cells(3, x) = sh3.Cells(k.Row, x + 1)
Next[/COLOR]
    MsgBox "Standart seçildi." & vbLf & _
    "", vbOKOnly + vbInformation, ""
    Else
    MsgBox "[ " & sh2.Range("B16").Value & " ] İsminde standart bulunamdı.", vbCritical, "UYARI"
End If
End Sub

 

[Erkand]

leumruk hocam sorun çözülmüştür.Çok teşekkür ederim.

 

[leumruk]

leumruk hocam sorun çözülmüştür.Çok teşekkür ederim.

Rica ederim.