Fare ile hücrenin renklenmesi

[ASLAN7410]

Merhaba hayırlı geceler, hayırlı bayramlar.

Forum ana sayfasındaki gibi, excel sayfasında Sayfa1'de mouse ile hücreye tıklamadan A ve L sütuna arasındaki hangi hücrenin üzerine gelirsem, bu sütunlar arasındaki o satırın sarı renge dönmesini istiyorum, forumda araştırdım ancak bulamadım.

Yardım edecek arkadaşlara şimdiden teşekkür ediyorum.

 

[Ömer BARAN]

Merhaba.
Fare ile hareket ederken olayını bilemiyorum ama aşağıdaki kod ile SEÇİLİ hücrenin bulunduğu satır A:L sütun aralığı sarı renge boyanır.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells.Interior.ColorIndex = xlNone
Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row).Interior.ColorIndex = 6
End Sub

 

[ASLAN7410]

Ömer Bey ilginize çok teşekkür ediyorum, hayırlı bayramlar.

Sayfadaki hücrelere fare ile tıkladığımda kod çalışıyor, fare ile hücreye tıklamadan hücre üzerinde ok işaretini gezdirdiğimde A ve L sütunu arasındaki satırın renklenmesini istiyorum, bu işlem yapılabilir mi?

 

[Merhum İdris SERDAR]

.

Buradaki örneklere bakın.

http://www.excel.web.tr/f60/mouse-over-fare-ile-tetikleme-t138394.html

http://www.excel.web.tr/f135/mouse-fare-ile-hucre-zerine-gelindioinde-renklendirme-teknioi-t138103.html

http://www.excel.web.tr/f135/yyllara-gore-l-nufuslary-projeksiyonu-grafikli-t144523.html



.

 

[ASLAN7410]

İdris Bey çok güzel çalışmalarınız var, maalesef çalışmalarınızdan yararlanarak istediğimi yapamadım, sizin yaptığınız örneklerde fare ile üzerine gelinmek istenen hücrelerde hep formüller var bu formülleri sildiğin zaman çalışmıyor.

Benim sayfamda manüel olarak hücrelere bilgi girildiği için formülle yapılan çalışma işime yaramayacak gibi görünüyor, makro ile yapılırsa daha iyi olacak sanırım.

Yardım eder misiniz?

 

[Merhum İdris SERDAR]

İdris Bey çok güzel çalışmalarınız var, maalesef çalışmalarınızdan yararlanarak istediğimi yapamadım, sizin yaptığınız örneklerde fare ile üzerine gelinmek istenen hücrelerde hep formüller var bu formülleri sildiğin zaman çalışmıyor.

Benim sayfamda manüel olarak hücrelere bilgi girildiği için formülle yapılan çalışma işime yaramayacak gibi görünüyor, makro ile yapılırsa daha iyi olacak sanırım.

Yardım eder misiniz?

.

Böyle bir şey mi?

http://www.excelgurusu.com/mouse-imleci-ustune-geldiginde-hucre-renklensin/


.

 

[ASLAN7410]

İdris Bey ilginize yine çok teşekkür ediyorum, benim istediğim bu forumun ana sayfası gibi fareyi excel sayfası hücreleri üzerinde gezdirdiğim zaman A ile L sütunu arasındaki satırın renklenmesini istemiştim.

 

[ASLAN7410]

Hayırlı sabahlar arkadaşlar.

Bu forumun ana sayfası gibi fareyi excel sayfası hücreleri üzerinde gezdirdiğim zaman A ile L sütunu arasındaki satırın renklenmesini istiyorum.

İdris Bey'in örneklerini inceledim, bu örneklerde hücrelerde formüller var, oysaki benim hücrelerde bilgilerim var, bundan dolayıda istediğim gibi yapamadım.

Bu soruma hala cevap bulamadım, bu şekilde istediğim gibi yapılabilir mi?

 

[halit3]

Hayırlı sabahlar arkadaşlar.

Bu forumun ana sayfası gibi fareyi excel sayfası hücreleri üzerinde gezdirdiğim zaman A ile L sütunu arasındaki satırın renklenmesini istiyorum.

İdris Bey'in örneklerini inceledim, bu örneklerde hücrelerde formüller var, oysaki benim hücrelerde bilgilerim var, bundan dolayıda istediğim gibi yapamadım.

Bu soruma hala cevap bulamadım, bu şekilde istediğim gibi yapılabilir mi?

Excel sayfalarındaki kod bölümünde

(MouseDown, MouseMove, MouseUp) olay yordamları yok onun için söylediğiniz yapılamaz.

Ancak belki api ile yapılabilir bunu da nette aramak lazım

 

[halit3]

Alternatif olarak
Bir modülün içine bu kodu yapıştır.

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
x As Long
y As Long
End Type

Sub GetTheMouseCursorPosition()
On Error Resume Next

Dim lngCurPos As POINTAPI
Do
GetCursorPos lngCurPos
'Display the "X" position in cell "A1."
'Display the "Y" position in cell "A2."
Cells(1, 1).Value = "X = " & lngCurPos.x
Cells(2, 1).Value = "Y = " & lngCurPos.y
Cells(3, 1).Value = ActiveWindow.RangeFromPoint(lngCurPos.x, lngCurPos.y).Address
Columns("A:L").Interior.ColorIndex = xlNone
sat = ActiveWindow.RangeFromPoint(lngCurPos.x, lngCurPos.y).Row
adres = Range("A" & sat & ":L" & sat).Address '.ColorIndex = 6
Cells(4, 1).Value = adres
Range(adres).Interior.ColorIndex = 6

'Govern the reporting range?
If lngCurPos.x = 337 And lngCurPos.y = 419 Then GoTo myWin Else

'If [A3] <> "" Then GoTo myStop Else
DoEvents
Loop

myWin:

End

'myStop:
End Sub

Sayfanın kod bölümüne bu kodu yapıştır.

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
GetTheMouseCursorPosition

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Cancel = True
End

End Sub

kodun çalışması için mause ile sağ tıklayın durdurmak içinde sol tıklayın.

 

[halit3]

Bu kodlarda farklı bir uygulama

Kodların çalışması için sayfaya bir adet TextBox1 nesnesi,bir adet CommandButton1, bir adet CommandButton2, bir adet IeTimer1 nesnesi ekleyin

(CommandButton1) durdur düğmesi
(CommandButton2) çalıştır düğöesi

ThisWorkbook bölümüne aşağıdaki kodu yapıştırın.

Private Sub Workbook_Activate()
On Error Resume Next
Set Sh = Sheets(ActiveSheet.Name)
For r = 1 To Sh.Shapes.Count
If TypeName(Sh.Shapes(r).OLEFormat.Object) = "OLEObject" Then
If TypeName(Sh.Shapes(r).OLEFormat.Object.Object) = "CommandButton" Then
Exit Sub
End If
End If
Next
Dim Obj As Object
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1")
With Obj
.Left = 504
.Top = 112
.Height = 27
.Width = 85
.Object.Caption = "Ana Sayfa"
End With
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Workbook_Activate
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
sut_ekle = 1
sat_ekle = 1

If Target.Column = Columns.Count Then sut_ekle = 0
If Target.Row = Rows.Count Then sat_ekle = 0

adres1 = ActiveWindow.RangeSelection.Address
a = InStr(Trim(adres1), ":")
If a = 0 Then
sat = ActiveWindow.Selection.Row + sat_ekle
sut = ActiveWindow.Selection.Column + sut_ekle
Else
sat = Range(Mid(adres1, a + 1, 15)).Row + sat_ekle
sut = Range(Mid(adres1, a + 1, 15)).Column + sut_ekle
hucre_adi = Range(Mid(adres1, a + 1, 15)).Address(False, False)
End If

If sat < 1 Then sat = 1
If sut < 1 Then sut = 1

If sat + 2 > Rows.Count Then sat = Rows.Count - 1
If sut + 2 > Columns.Count Then sut = Columns.Count - 1


ActiveSheet.Shapes("CommandButton1").Top = Cells(sat, sut).Rows.Top
ActiveSheet.Shapes("CommandButton1").Left = Cells(sat, sut).Rows.Left
ActiveSheet.Shapes("CommandButton1").Height = 27
ActiveSheet.Shapes("CommandButton1").Width = 85
End Sub

Sayfanın kod bölümüne aşağıdaki kodu yapıştırın.

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI
X As Long
Y As Long
End Type


Private Sub CommandButton1_Click()
IeTimer1.Interval = 0
IeTimer1.Enabled = False
IeTimer1_Timer
Columns("A:L").Interior.ColorIndex = xlNone

End Sub
Private Sub CommandButton2_Click()
IeTimer1.Interval = 100
IeTimer1.Enabled = True
IeTimer1_Timer

End Sub


Private Sub IeTimer1_Timer()
On Error Resume Next
Dim lngCurPos As POINTAPI

GetCursorPos lngCurPos

sat = Val(ActiveWindow.RangeFromPoint(lngCurPos.X, lngCurPos.Y).Row)
sut = Val(ActiveWindow.RangeFromPoint(lngCurPos.X, lngCurPos.Y).Column) + 1
ActiveSheet.Shapes("CommandButton1").Top = Cells(sat, sut).Rows.Top
ActiveSheet.Shapes("CommandButton1").Left = Cells(sat, sut).Rows.Left
If sat > 0 Then
If sat <> Val(Sheets(ActiveSheet.Name).TextBox1.Text) Then
Columns("A:L").Interior.ColorIndex = xlNone
adres = Range("A" & sat & ":L" & sat).Address
Range(adres).Interior.ColorIndex = 6

If sat = 1 Then
IeTimer1.Interval = 0
IeTimer1.Enabled = False
Columns("A:L").Interior.ColorIndex = xlNone
End

End If
Sheets(ActiveSheet.Name).TextBox1.Text = sat
End If
End If



End Sub

 

[halit3]

Bu uygulamada farklı

Kodların çalışması için sayfaya bir adet ToggleButton1 nesnesi, bir adet IeTimer1 nesnesi ekleyin

ThisWorkbook bölümüne aşağıdaki kodu yapıştırın.

Private Sub Workbook_Activate()
'On Error Resume Next
Set Sh = Sheets(ActiveSheet.Name)
For r = 1 To Sh.Shapes.Count
If TypeName(Sh.Shapes(r).OLEFormat.Object) = "OLEObject" Then
If TypeName(Sh.Shapes(r).OLEFormat.Object.Object) = "ToggleButton" Then
'MsgBox Sh.Shapes(r).OLEFormat.Object.ShapeRange.LockAspectRatio
Exit Sub
End If
End If
Next

Dim Obj As Object
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ToggleButton.1")
With Obj
.Left = 504
.Top = 112
.Height = 27
.Width = 85

'.msoTrue
.Object.Caption = "Çalıştır"
.ShapeRange.LockAspectRatio = 0 '-1
'.LockAspectRatio = msoFalse
With Obj.Object
'.BackColor = RGB(204, 204, 204)
'.SpecialEffect = 1
'.TextAlign = 2
'.Font.Size = 8
'.Font.Bold = True


End With

End With
Exit Sub
For Each shp In ActiveSheet.Shapes
MsgBox shp.Name
shp.ShapeRange.LockAspectRatio = msoFalse
Next shp

Exit Sub
'delete ActiveX Control ScrollBar objects
For Each objScrlBar In ActiveSheet.OLEObjects
'TypeName Function returns the data-type about a variable - TypeName(varname)
If TypeName(objScrlBar.Object) = "ScrollBar" Then objScrlBar.Delete
Next objScrlBar

'delete Form Control ScrollBar objects
For Each shpScrlBar In ActiveSheet.Shapes
If shpScrlBar.Type = msoFormControl Then
If shpScrlBar.FormControlType = xlScrollBar Then shpScrlBar.Delete
End If
Next shpScrlBar





End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Workbook_Activate
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
sut_ekle = 1
sat_ekle = 1

If Target.Column = Columns.Count Then sut_ekle = 0
If Target.Row = Rows.Count Then sat_ekle = 0

adres1 = ActiveWindow.RangeSelection.Address
a = InStr(Trim(adres1), ":")
If a = 0 Then
sat = ActiveWindow.Selection.Row + sat_ekle
sut = ActiveWindow.Selection.Column + sut_ekle
Else
sat = Range(Mid(adres1, a + 1, 15)).Row + sat_ekle
sut = Range(Mid(adres1, a + 1, 15)).Column + sut_ekle
hucre_adi = Range(Mid(adres1, a + 1, 15)).Address(False, False)
End If

If sat < 1 Then sat = 1
If sut < 1 Then sut = 1

If sat + 2 > Rows.Count Then sat = Rows.Count - 1
If sut + 2 > Columns.Count Then sut = Columns.Count - 1


ActiveSheet.Shapes("ToggleButton1").Top = Cells(sat, sut).Rows.Top
ActiveSheet.Shapes("ToggleButton1").Left = Cells(sat, sut).Rows.Left
'ActiveSheet.Shapes("ToggleButton1").LockAspectRatio = msoTrue

ActiveSheet.Shapes("ToggleButton1").Height = 27
ActiveSheet.Shapes("ToggleButton1").Width = 85
End Sub

Sayfanın kod bölümüne aşağıdaki kodu yapıştırın.

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Sub ToggleButton1_Click()
If ToggleButton1.Value = False Then
IeTimer1.Interval = 0
IeTimer1.Enabled = False
IeTimer1_Timer
Columns("A:L").Interior.ColorIndex = xlNone
ToggleButton1.Caption = "Çalıştır"
Else
IeTimer1.Interval = 100
IeTimer1.Enabled = True
IeTimer1_Timer
End If

End Sub


Private Sub IeTimer1_Timer()
On Error Resume Next
Dim lngCurPos As POINTAPI

GetCursorPos lngCurPos

sat = Val(ActiveWindow.RangeFromPoint(lngCurPos.X, lngCurPos.Y).Row)
sut = Val(ActiveWindow.RangeFromPoint(lngCurPos.X, lngCurPos.Y).Column) + 1




If sut - 1 <= 12 Then
If sat > 0 Then

If sat <> Val(Mid(Sheets(ActiveSheet.Name).ToggleButton1.Caption, 1, 5)) Then
ActiveSheet.Shapes("ToggleButton1").Top = Cells(sat, sut).Top
ActiveSheet.Shapes("ToggleButton1").Left = Cells(sat, sut).Left + 20
'ActiveSheet.Shapes("ToggleButton1").Width = Cells(sat, sut).Width

Columns("A:L").Interior.ColorIndex = xlNone
adres = Range("A" & sat & ":L" & sat).Address
Range(adres).Interior.ColorIndex = 6



End If

End If
Else
sat = 0
End If
Sheets(ActiveSheet.Name).ToggleButton1.Caption = Format(sat, "00000") & " Durdur"



End Sub

Kodların çalışması için ietimer.ocx nesnesi kurulu olması lazım
Ekli dosyada Dill dosyasını yükle.exe dosyası ve ietimer.ocx nesnesi var
exe dosyası ietimer.ocx dosyasını otomatik olarak regsvr32.exe dosyasına register yapıyor

 

[ASLAN7410]

Merhaba Halit Bey ilginiz için çok teşekkür ediyorum, 10.mesajınızdaki yaptığınız çalışma harika olmuş, ellerinize sağlık çok teşekkür ediyorum, ancak diğer yapmış olduğunuz örnekler olan 11.ve 12.mesajınızdaki eklemiş olduğunuz sayfalar hata veriyor, çalışmıyor.

 

[halit3]

Merhaba Halit Bey ilginiz için çok teşekkür ediyorum, 10.mesajınızdaki yaptığınız çalışma harika olmuş, ellerinize sağlık çok teşekkür ediyorum, ancak diğer yapmış olduğunuz örnekler olan 11.ve 12.mesajınızdaki eklemiş olduğunuz sayfalar hata veriyor, çalışmıyor.

Aşağıdaki linkleri irdeleyiniz.

Kodların çalışması için ietimer.ocx nesnesi kurulu olması lazım

http://www.excel.web.tr/f167/timer-nesnesinin-kurulumu-t78713.html
http://www.excel.web.tr/f48/msakiye-t149881.html

 

[halit3]

Aşağıdaki linkde
Dill dosyasını yükle.exe dosyası ve ietimer.ocx nesnesi var
exe dosyası ietimer.ocx dosyasını otomatik olarak regsvr32.exe dosyasına register yapıyor

http://www.excel.web.tr/f48/msakiye-t149881.html

 

[ASLAN7410]

Halit Bey dediğiniz gibi dosyalarıda yükledim çok güzel olmuş ellerinize sağlık harika çalışıyor, çok teşekkür ediyorum Allah razı olsun, hayırlı çalışmalar.

 

[halit3]

Halit Bey dediğiniz gibi dosyalarıda yükledim çok güzel olmuş ellerinize sağlık harika çalışıyor, çok teşekkür ediyorum Allah razı olsun, hayırlı çalışmalar.

Teşekkürler iyi çalışmalar