Ara Bul Dediğimiz renklensin

[muzaffer.sm]

Arkadaşlar Merhaba,

Herhangi bir excel sayfasında ara bul ile bulduğumuz verinin renklendirmesini manuel olarak değilde otomatik olarak yapabilirmiyiz. Bir inputbox içinden çıkmadan (yani excel ara bul diyerek sonra mouse ile renklendirme yapmadan) bulmak istediğimiz veriyi yazmak sureti ile bulunan veri renklensin
Bu mümkünmüdür.

 

[halit3]

Arkadaşlar Merhaba,

Herhangi bir excel sayfasında ara bul ile bulduğumuz verinin renklendirmesini manuel olarak değilde otomatik olarak yapabilirmiyiz. Bir inputbox içinden çıkmadan (yani excel ara bul diyerek sonra mouse ile renklendirme yapmadan) bulmak istediğimiz veriyi yazmak sureti ile bulunan veri renklensin
Bu mümkünmüdür.

işte kod

Sub BUL23()
Range("A1").Select
Range("A:IV").Interior.ColorIndex = xlNone
ad = InputBox("aranacak değeri yazınız.", "DEĞER", "")
If ad = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
sat = 0
yer = ""
With Range("A:IV")
Set d = .Find(ad, LookIn:=xlFormulas, LookAt:=xlPart) 'Hücreye göre arar
'Set d = .Find(ad, LookIn:=xlValues, LookAt:=xlWhole) 'Kelimeye göre arar
If Not d Is Nothing Then
FirstAddress = d.Address
Do
d.Interior.ColorIndex = 3
d.Select
If yer <> "" Then
ekle = ","
Else
ekle = ""
End If
yer = yer & ekle & d.Address(False, False)
yer1 = yer1 & d.Address(False, False) & Chr(10)
sat = sat + 1
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
If sat = 0 Then
MsgBox ad & "  değeri bulunamamıştır"
Exit Sub
End If
Range(yer).Select
MsgBox yer1 & Chr(10) & sat & " adet bulundu", vbInformation, "Hücrelerin numaraları"

End Sub

 

[muzaffer.sm]

Merhaba Halit Abi,

Hemen yanıt sizden gelmiş.

Çözüm olmuş. Abi, fakat önceki bulunan verilerin renkleri yerinde durursa daha iyi olacak
çünkü aradığımız veriler renkli olarak kalsınki, bulunmayanlar ise belli olsun.
Her aramada en son veri renkli kalmış oluyor.Önceki renkli verilerin biçimleri temizlenmiş oluyor.
Her aranan veri renkli yapalimki ,bulunmayanlar meydana çıkmış olsun.

 

[halit3]

Merhaba Halit Abi,

Hemen yanıt sizden gelmiş.

Çözüm olmuş. Abi, fakat önceki bulunan verilerin renkleri yerinde durursa daha iyi olacak
çünkü aradığımız veriler renkli olarak kalsınki, bulunmayanlar ise belli olsun.
Her aramada en son veri renkli kalmış oluyor.Önceki renkli verilerin biçimleri temizlenmiş oluyor.
Her aranan veri renkli yapalimki ,bulunmayanlar meydana çıkmış olsun.

Bu bölümü sil

Range("A:IV").Interior.ColorIndex = xlNone

 

[somon1]

Bu bölümü sil

Range("A:IV").Interior.ColorIndex = xlNone

hocam elinize sağlık,

ikinci aramada renk kalkmıyor fakat başka bir renk atması mümkünmü?mesela 5 aramaya kadar farklı renkler...

 

[halit3]

hocam elinize sağlık,

ikinci aramada renk kalkmıyor fakat başka bir renk atması mümkünmü?mesela 5 aramaya kadar farklı renkler...

Yedi aramaya kadar farklı renk veriyor kod

[COLOR="red"]Dim renkli[/COLOR]

Private Sub CommandButton1_Click()

[COLOR="red"]ReDim renk(7)

renk(1) = 3
renk(2) = 4
renk(3) = 33
renk(4) = 39
renk(5) = 37
renk(6) = 12
renk(7) = 44

renkli = renkli + 1[/COLOR]

Range("A1").Select

msg1 = MsgBox("Renkler silinsinmi.? ", vbYesNo + vbInformation, "u y a r ı !")

If msg1 = vbYes Then
Range("A:IV").Interior.ColorIndex = xlNone
End If


ad = InputBox("aranacak değeri yazınız.", "DEĞER", "")
If ad = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
sat = 0
yer = ""
With Range("A:IV")
Set d = .Find(ad, LookIn:=xlFormulas, LookAt:=xlPart) 'Hücreye göre arar
'Set d = .Find(ad, LookIn:=xlValues, LookAt:=xlWhole) 'Kelimeye göre arar
If Not d Is Nothing Then
FirstAddress = d.Address
Do
d.Interior.ColorIndex = [COLOR="red"]renk(renkli)[/COLOR]
d.Select
If yer <> "" Then
ekle = ","
Else
ekle = ""
End If
yer = yer & ekle & d.Address(False, False)
yer1 = yer1 & d.Address(False, False) & Chr(10)
sat = sat + 1
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
If sat = 0 Then
MsgBox ad & "  değeri bulunamamıştır"
Exit Sub
End If
Range(yer).Select
[COLOR="Red"]If renkli >= 7 Then renkli = 0[/COLOR]
MsgBox yer1 & Chr(10) & sat & " adet bulundu", vbInformation, "Hücrelerin numaraları"

End Sub

 

[mustilem23]

merhaba ,

ben sadece normal bir excel de arama yaptığım da bulunan hücre başka bir renk olarak cıkmasını talep ediyorum ,saydam olunca gozden kaça biliyor yardımcı olabilir misiniz teşekkürler.

 

[somon1]

hocam elinize sağlık teşekkür ederim..

 

[halit3]

hocam elinize sağlık teşekkür ederim..

Teşekkürler iyi çalışmalar

 

[mustilem23]

halit Bey ,

ben sadece normal bir excel de arama yaptığım da bulunan hücre başka bir renk olarak cıkmasını talep ediyorum ,saydam olunca gozden kaça biliyor yardımcı olabilir misiniz teşekkürler.

 

[halit3]

halit Bey ,

ben sadece normal bir excel de arama yaptığım da bulunan hücre başka bir renk olarak cıkmasını talep ediyorum ,saydam olunca gozden kaça biliyor yardımcı olabilir misiniz teşekkürler.

Yanlış bir şey söylemeyim ama bu dediğiniz şey sadece makro ile yapılıyor olarak biliyorum.

 

[mustilem23]

teşekkür ederim olsun idare ederim böyle

 

[halit3]

teşekkür ederim olsun idare ederim böyle

İyi çalışmalar

 

[mustilem23]

Halit Bey ,

Bu kodu tüm exceller de nasıl çalıştırabilirim ? (yeni bir excel sayfası açtığım da ctrl +shıft+B tuşunu kullanarak)
personelxl nin modülüne ekledim fakat bir türlü olmadı yardımcı olabilir misiniz.

Sub BUL23()
Range("A1").Select
Range("A:IV").Interior.ColorIndex = xlNone
ad = InputBox("aranacak değeri yazınız.", "DEĞER", "")
If ad = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
sat = 0
yer = ""
With Range("A:IV")
Set d = .Find(ad, LookIn:=xlFormulas, LookAt:=xlPart) 'Hücreye göre arar
'Set d = .Find(ad, LookIn:=xlValues, LookAt:=xlWhole) 'Kelimeye göre arar
If Not d Is Nothing Then
FirstAddress = d.Address
Do
d.Interior.ColorIndex = 3
d.Select
If yer <> "" Then
ekle = ","
Else
ekle = ""
End If
yer = yer & ekle & d.Address(False, False)
yer1 = yer1 & d.Address(False, False) & Chr(10)
sat = sat + 1
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
If sat = 0 Then
MsgBox ad & "  değeri bulunamamıştır"
Exit Sub
End If
Range(yer).Select
MsgBox yer1 & Chr(10) & sat & " adet bulundu", vbInformation, "Hücrelerin numaraları"

End Sub

 

[halit3]

Aşagıdaki kodu yeni bir excel dosyası oluştur ThisWorkbook sayfasına kopyala sonra farklı kaydet seçeneğinden Microsoft office Excel Eklentisi (*.xla) olarak açılan Addins klasörüne kaydet ve sonra Sayfadan Araçlar Eklentiler bölümünde farklı kaydettiğin dosyayı bul ve tikini işaretle sayfaya mause ili sağ tıkla Bul23 tıkla

Private Sub Workbook_Open()

Application.CommandBars("Cell").Reset

Dim menü_ekle As CommandBarControl
Set menü_ekle = Application.CommandBars("Cell").Controls.Add
With menü_ekle
.Caption = "Bul23"
.OnAction = "ThisWorkbook.Bul23"
End With

End Sub
Sub Bul23()
Range("A1").Select
Range("A:IV").Interior.ColorIndex = xlNone
ad = InputBox("aranacak değeri yazınız.", "DEĞER", "")
If ad = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
sat = 0
yer = ""
With Range("A:IV")
Set d = .Find(ad, LookIn:=xlFormulas, LookAt:=xlPart) 'Hücreye göre arar
'Set d = .Find(ad, LookIn:=xlValues, LookAt:=xlWhole) 'Kelimeye göre arar
If Not d Is Nothing Then
FirstAddress = d.Address
Do
d.Interior.ColorIndex = 3
d.Select
If yer <> "" Then
ekle = ","
Else
ekle = ""
End If
yer = yer & ekle & d.Address(False, False)
yer1 = yer1 & d.Address(False, False) & Chr(10)
sat = sat + 1
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
If sat = 0 Then
MsgBox ad & "  değeri bulunamamıştır"
Exit Sub
End If
Range(yer).Select
MsgBox yer1 & Chr(10) & sat & " adet bulundu", vbInformation, "Hücrelerin numaraları"


End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim r
For r = 1 To Application.CommandBars("Cell").Controls.Count
'MsgBox Application.CommandBars("Cell").Controls(r).Caption
If Application.CommandBars("Cell").Controls(r).Caption = "Bul23" Then
Application.CommandBars("Cell").Controls(r).Delete
End If
Next


End Sub

 

[mustilem23]

Halit Bey ,

ilginize teşekkür ederim,deneme yapamadım çünkü VBAProject pencerem de ThisWorkbook adlı bir klasör yok epey arastırdım kurcaladım fakat bir sonuca ulaşamadım.


ThisWorkbook klasörü nasıl ekleyebiliriz.


VBAProject ekranım da bunlar var ,

VBAProject (arabulhızlı)
microsoft excelobjeck
buçalışma kitabı
sayfa 1
sayfa 2
sayfa 3
module1

VBAProject (arabulhızlı)
buçalışma kitabı
sayfa 1
forms
userform

 

[mustilem23]

Halit Bey ,

ilginize teşekkür ederim,deneme yapamadım çünkü VBAProject pencerem de ThisWorkbook adlı bir klasör yok epey arastırdım kurcaladım fakat bir sonuca ulaşamadım.


ThisWorkbook klasörü nasıl ekleyebiliriz ?


VBAProject ekranım da bunlar var ,

VBAProject (arabulhızlı)
microsoft excelobjeck
buçalışma kitabı
sayfa 1
sayfa 2
sayfa 3
module1

VBAProject (arabulhızlı)
buçalışma kitabı
sayfa 1
forms
userform

 

[halit3]

Kodları Buçalışma kitabı nın içine kopyalayın

 

[mustilem23]

Halit Bey bahsettiğiniz şartların hepsini yaptım fakat sağ klilk içerisine bul23 gelmedi ,yardımcı olabilir misiniz.

excel vba içerisinde şuan


VBAProject (bul23.xla)
microsoft excelobjeck
buçalışma kitabı ------------ tıkladığımda kopyaladığım kodları görüyorum başka bir excelde açtığımda
sayfa 1
sayfa 2
sayfa 3
VBAProject (bul23.xlsx)
microsoft excelobjeck
buçalışma kitabı
sayfa 1
sayfa 2
sayfa 3


excel ekranında farklı kaydet dediğim de

C:\Users\mdogru\AppData\Roaming\Microsoft\AddIns

kayıt türü :97 2003 eklentisini seçtim acaba buradamı bir durum var .ben excel 2010 kullanıyorum

fakat geliştirici eklentiler ekranın da bul23 işaretleyip tamam denebiliyor.

 

[halit3]

Profilinde 2003 ve 2007 yazıyor neyse profilinizi düzeltin

Şimdi farklı kaydet dediğinizde açılın pencereden kayıt türüne Excel Eklentisi (*.xlam) olarak seçin ve dosya adını da deneme yazıp kaydedin sonra açık olan ber excel sayfasından excelin amlemine tiklayın
Excel seçenekler/eklentilir/excel eklentileri ve git dügmesine tıklayın bir eklenti penceresi açılmış olması gerekiyor orada deneme olarak kaydettiğimiz bölümün tikini işaretleyin.