hücre üzerine gelindiğinde satır boyaması ve değer oluşturması

[bebar]

Merhaba;

Aşağıda kullandığım kod b2:d5 hücreleri içinde üzerine geldiğim zaman hücreyi kırmızı yapıyor, fakat istediğim

* A14:A37 hücrelerinin üzerine geldiğim zaman hücrenin sağındaki 5 hücreyi boyaması gerekiyor

* üzerine geldiğim hücrenin 1 hücre sağındaki değeri G5 hücresine yazması gerekiyor.

teşekkür ederim





Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
d = 3
If X < d Or X > Label1.Width - d Or Y < d Or Y > Label1.Height - d Then
Range("champ").Interior.ColorIndex = xlNone
Else
Hcel = Range("champ").Cells(1, 1).Height
Lcel = Range("champ").Cells(1, 1).Width
Yc = Int(Y / Hcel)
Xc = Int(X / Lcel)
Range("champ").Interior.ColorIndex = xlNone
Range("champ").Cells(1, 1).Offset(Yc, Xc).Interior.ColorIndex = 3

End If
End Sub

 

[bebar]

hocam yokmudur yardımcı olabilecek bir arkadaş

 

[askm]

Aşağıdaki kodları kullanabilirsiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
Cells.Interior.ColorIndex = xlNone
If Intersect(Target, [A14:A37]) Is Nothing Then Exit Sub
Range(Cells(Target.Row, 1), Cells(Target.Row, 6)).Interior.ColorIndex = 3
Range("g5").Value = Cells(Target.Row, 1).Value
End Sub

 

[bebar]

hocam teşekkür ederim ama maalesef çalşmyor

 

[yanginci34]

Merhaba; sayın askm ufak bir düzeltme yaptım affınıza sığınarak.
Sayın bebar kırmızı yer gibi düzeltme yapıp denermisiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
Cells.Interior.ColorIndex = xlNone
If Intersect(Target, [A14:A37]) Is Nothing Then Exit Sub
Range(Cells(Target.Row, 1), Cells(Target.Row, 6)).Interior.ColorIndex = 3
Range("g5").Value = Cells(Target.Row, 2).Value
End Sub

 

[bebar]

Alakanız için teşekkür ederim ama yine malesef çalışmıyor neyse daha fazla meşgul etmeyeyim sizi alternatif çözümlere yönelmem gerekiyor galiba

 

[askm]

Örnek dosya eklerseniz. Daha net çözüm alırsanız.

 

[bebar]

dosyam ektedir.

 

[yanginci34]

buyrun Sayın askm nin kodu gayet güzel çalışıyor.
Ekli dosyayı görüntüle rapor buyrun.xlsm

 

[bebar]

Çok teşekkür ederim çok faydası oldu