Aktarılan hücredeki açıklamanında aktarılması

[1Al2Ver]

İyi sabahlar, arzuladığım işleme ait örnek bulunabilir maksadıyla, forumda ;

1) "Hücrede Açıklama" başlığıya aratıldı ; 26 sonuç çıktı (isteğime uymadı)
2) "Veri Taşınırken Açıklamada Taşınsın" başlığıyla aratıldı ; sonuç çıkmadı
3) "Veri Aktarırken" başlığıyla aratıldı ; sonuç çıkmadı
4) "Açıklama Aktarma" başlığıyla aratıldı ; Macro-VBA adlı başlıkta 01.01.2008 tarihinde Sayın tahsinarat sormuş ve Sayın V.Basic For Applications cevaplamış, ancak orada istenen, aktarılan hücrede "açıklama" isimli başlığa sahip olan hücrenin içerisindeki verinin, diğer bilgiler ile beraber aktarılmasıydı,

Sonuç'ta, konu aynı gibi görükse de istediğime göre bir örnek bulamadım, yaptığım işlemde ise,

1) "Kişisel" sayfasındaki A5 hücresine manuel "soyad" girildiğinde, B5 hücresine, "Genel" sayfasındaki B sütünundaki isimlerden eşleşen geliyor,

2) "Genel" sayfasındaki isimlerde, açıklamalarında resim var,

İstek ; "Kişisel" sayfasına taşınan isimlerle birlikte, açıklama da taşınabilir mi ? Teşekkür ederim.

 

[xxcell]

Enteresan bir şekilde AÇIKLAMAYA RESİM EKLENMESİ ile ilk defa karşılaşıyorum.
Gayet hoş olmuş. Açıklamaya resim eklemek isteyenler, Açıklamayı biçimlendirip, renk olarak DOLGU EFEKLERİNİ seçip, RESİM sekmesinden istedikleri resmi atayabilirler.

Açıklamadaki metni aktarmak basit ama Açıklamanın dolgu renginideki resmi aktarabilmek biraz karışık geldi. En kestirme çözüm copy - paste

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$5" Then Exit Sub
 
Set f = Sheets("genel").[b:c].Find([a5])
 
If f Is Nothing Then
    MsgBox [c7] & " bulunamadı.", vbInformation
Else
    
  Sheets("genel").Range("b" & f.Row).Copy
  Range("B5").Select
  Paste
  Application.CutCopyMode = False
    
End If
 
Set f = Nothing
 
End Sub

Bu arada iyi sabahlar

 

[Zeki Gürsoy]

Oldu galiba

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$5" Then Exit Sub
 
Set f = Sheets("genel").[b:c].Find([a5])
 
If f Is Nothing Then
    MsgBox [c7] & " bulunamad&#305;.", vbInformation
Else
    [b5] = Sheets("genel").Range("b" & f.Row)

    If Sheets("genel").Range("b" & f.Row).Comment.Text <> "" Then
        Sheets("genel").Range("b" & f.Row).Copy
        [b5].PasteSpecial Paste:=xlPasteComments
        Application.CutCopyMode = False
    End If

End If
 
Set f = Nothing
 
End Sub

 

[1Al2Ver]

Sayın Anemos, merhaba, oldu hem de süper oldu, elinize sağlık,

İhtiyacım olan benzer bir kod, "Sayfa2" B5 hücresi; "Sayfa1" B3 ve/veya C3 hücresindeki verilerden birisi girildiğinde, verileri "Sayfa2" deki C6:H6 aralığına aktarmaktadır,

Ben "Sayfa1" deki C kolonundaki soyadı bölümüne açıklama(resim) ekledim,

Açıklamanın da aktarılması için bir önceki koda ne ilave etmeliyim,

teşekkür ederim, saygılarımla

 

[1Al2Ver]

Farklı sayfadaki (Genel) hücre verisini, açıklaması ile birlikte aktarırken aynı sayfadaki diğer hücrelerdeki verileri de, aktarmak istiyorum,

OLAY ; "Kişisel" sayfası A5 hücresine "SOYADI" yazıldığında "Genel" sayfasından "Kişisel" sayfası B5 hücresine veri aktarılmaktadır,

İSTEK; A5 hücresine "SOYADI" yazıldığında "Genel" sayfasından "Kişisel" sayfası C5:O5 aralığına da veri aktarılmasıdır.

Olayı gerçekleşiren Macronun Kodu Sayın Anemos'un 3 numaralı mesajındaki koddur.

Yardımcı olabilecek arkadaşlara teşekkür ederim, saygılarımla.

 

[1Al2Ver]

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$5" Then Exit Sub

Set f = Sheets("genel").[b:c].Find([a5])

If f Is Nothing Then
MsgBox [a5] & " bulunamad&#305;.", vbInformation
Else
[b5] = Sheets("genel").Range("b" & f.Row)
[c5] = Sheets("genel").Range("c" & f.Row)
[d5] = Sheets("genel").Range("d" & f.Row)
[e5] = Sheets("genel").Range("e" & f.Row)
[f5] = Sheets("genel").Range("f" & f.Row)
[g5] = Sheets("genel").Range("g" & f.Row)
[h5] = Sheets("genel").Range("h" & f.Row)
[&#305;5] = Sheets("genel").Range("&#305;" & f.Row)
[j5] = Sheets("genel").Range("j" & f.Row)
[k5] = Sheets("genel").Range("k" & f.Row)
[l5] = Sheets("genel").Range("l" & f.Row)
[m5] = Sheets("genel").Range("m" & f.Row)
[n5] = Sheets("genel").Range("n" & f.Row)
[o5] = Sheets("genel").Range("o" & f.Row)

If Sheets("genel").Range("b" & f.Row).Comment.Text <> "" Then

Sheets("genel").Range("b" & f.Row).Copy
[b5].PasteSpecial Paste:=xlPasteComments


End If

End If

Set f = Nothing

End Sub

&#350;ayet "Genel" sayfas&#305; B5'te a&#231;&#305;klama yok ise (run-time error "91") K&#305;rm&#305;z&#305; sat&#305;r da debug hatas&#305; al&#305;yorum, bu kod nas&#305;l d&#252;zelmeli, te&#351;ekk&#252;r ederim.

 

[Zeki Gürsoy]

4. mesaj i&#231;in.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
 
If Target.Address <> "$B$5" Then Exit Sub
 
Set f = Sheets("sayfa1").[b:c].Find([b5])
 
If f Is Nothing Then
    MsgBox [b5] & " bulunamad&#305;.", vbInformation
Else
    [c6] = Sheets("sayfa1").Range("c" & f.Row)
    [d6] = Sheets("sayfa1").Range("d" & f.Row)
    [e6] = Sheets("sayfa1").Range("e" & f.Row)
    [f6] = Sheets("sayfa1").Range("f" & f.Row)
    [g6] = Sheets("sayfa1").Range("g" & f.Row)
    [h6] = Sheets("sayfa1").Range("h" & f.Row)
 
    If Sheets("sayfa1").Range("b" & f.Row).Comment.Text <> "" Then
        Sheets("sayfa1").Range("c" & f.Row).Copy
        [c6].PasteSpecial Paste:=xlPasteComments
        Application.CutCopyMode = False
    End If
 
End If
 
Set f = Nothing
End Sub

 

[1Al2Ver]

4. mesaj için.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
 
If Target.Address <> "$B$5" Then Exit Sub
 
Set f = Sheets("sayfa1").[b:c].Find([b5])
 
If f Is Nothing Then
    MsgBox [b5] & " bulunamadı.", vbInformation
Else
    [c6] = Sheets("sayfa1").Range("c" & f.Row)
    [d6] = Sheets("sayfa1").Range("d" & f.Row)
    [e6] = Sheets("sayfa1").Range("e" & f.Row)
    [f6] = Sheets("sayfa1").Range("f" & f.Row)
    [g6] = Sheets("sayfa1").Range("g" & f.Row)
    [h6] = Sheets("sayfa1").Range("h" & f.Row)
 
    If Sheets("sayfa1").Range("b" & f.Row).Comment.Text <> "" Then
        Sheets("sayfa1").Range("c" & f.Row).Copy
        [c6].PasteSpecial Paste:=xlPasteComments
        Application.CutCopyMode = False
    End If
 
End If
 
Set f = Nothing
End Sub

Sayın Anemos, aynı konu için sizi 2 kez yordum, işim görüldü, teşekkür ederim.Saygılarımla.