• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Formül Düzenleme

S

sedsa

Katılım
14 Mayıs 2009
Mesajlar
95
Excel Vers. ve Dili
Türkçe 2010
Merhabalar;
Çalışma sayfasında değil de çalışma kitabında arama yapmak için ve verinin bulunduğu hücreyi değil de verinin bulunduğu satırı (ilk 11 hücreyi ) renklendirmek için aşağıdaki formülü nasıl düzenlemem gerekir?

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
 
Hiç değilse bir arkadaş çalışma kitabında arama konusunda yardımcı olabilir mi??
 
Hatalar mevcuttu ikinci arama gerçekleşmiyordu düzeltildi kontrol ediniz;
Kod: 
Sub BUL23()
'On Error Resume Next
'Dim ad As String
ActiveSheet.Select
ActiveSheet.Range("b3").Select

ActiveSheet.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 = ""

Set d = ActiveSheet.Range("A:IV").Find(ad, LookIn:=xlFormulas, LookAt:=xlPart) 'Hücreye göre arar
'Set d = .Find(ad, LookIn:=xlValues, LookAt:=xlWhole) 'Kelimeye göre arar
'With Range("A:IV")
If Not d Is Nothing Then
FirstAddress = d.Address
Do

d.Rows.Select
d.Rows.Interior.ColorIndex = 3
With ActiveSheet
.Range("a" & d.Row).Interior.ColorIndex = 3
.Range("b" & d.Row).Interior.ColorIndex = 3
.Range("c" & d.Row).Interior.ColorIndex = 3
.Range("d" & d.Row).Interior.ColorIndex = 3
.Range("e" & d.Row).Interior.ColorIndex = 3
.Range("f" & d.Row).Interior.ColorIndex = 3
.Range("g" & d.Row).Interior.ColorIndex = 3
.Range("h" & d.Row).Interior.ColorIndex = 3
.Range("ı" & d.Row).Interior.ColorIndex = 3
.Range("j" & d.Row).Interior.ColorIndex = 3
.Range("k" & d.Row).Interior.ColorIndex = 3

End With
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 = ActiveSheet.Range("A:IV").FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If

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
 
Son düzenleme:
tşk ederim ama yine çalışma kitabında aramıyor.
 
Gayet güzel Çalışıyor; her hangi bir sayfa açın makroyu elle deneyin
 
üstat dosya ektedir maalesef tüm sayfalarda aramıyor yalnızca açık sayfada buluyor sanırım ben bir şeyi yanlış yapıyorum.
 

Ekli dosyalar

Üstat eğer bu dosyaya da bir bakabilirsen; bu daha iyi işime yarar bunun da tüm çalışma sayfalarında arama yapması gerekiyor.yardımların için şimdiden teşekkür ederim.
 

Ekli dosyalar

  • bul.xls
    bul.xls
    39.5 KB · Görüntüleme: 3
Kod: 
Sub kitapta_BUL23()
'On Error Resume Next
'Dim ad As String
Dim x As Integer
   Dim s As Sheets

ActiveSheet.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 = ""
Sayfa1.Select
ActiveSheet.Range("A:IV").Interior.ColorIndex = xlNone
syf = ActiveWorkbook.Sheets.Count
For x = 1 To syf
If x > syf Then GoTo hst


hstbir:
If x > syf Then GoTo hst
Sheets(x).Select
ActiveSheet.Range("A:IV").Interior.ColorIndex = xlNone
Set d = ActiveSheet.Range("A:IV").Find(ad, LookIn:=xlFormulas, LookAt:=xlPart) 'Hücreye göre arar
'Set d = .Find(ad, LookIn:=xlValues, LookAt:=xlWhole) 'Kelimeye göre arar
'With Range("A:IV")
If Not d Is Nothing Then
FirstAddress = d.Address
Do

d.Rows.Select
d.Rows.Interior.ColorIndex = 3
With ActiveSheet

.Range("b" & d.Row).Interior.ColorIndex = 3
.Range("c" & d.Row).Interior.ColorIndex = 3
.Range("d" & d.Row).Interior.ColorIndex = 3
.Range("e" & d.Row).Interior.ColorIndex = 3
.Range("f" & d.Row).Interior.ColorIndex = 3
.Range("g" & d.Row).Interior.ColorIndex = 3
.Range("h" & d.Row).Interior.ColorIndex = 3
.Range("ı" & d.Row).Interior.ColorIndex = 3
.Range("j" & d.Row).Interior.ColorIndex = 3
.Range("k" & d.Row).Interior.ColorIndex = 3

End With
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 = ActiveSheet.Range("A:IV").FindNext(d)

Loop While Not d Is Nothing And d.Address <> FirstAddress
'x = ActiveSheet.Index + 1
End If
Next
If sat = 0 Then
MsgBox ad & " değeri bulunamamıştır"
Exit Sub
End If
hst:
MsgBox yer1 & Chr(10) & sat & " adet bulundu", vbInformation, "Hücrelerin numaraları"

End Sub
Makro hazır
 
Son düzenleme:
Kod: 
Sub hepsini_BUL23()
'On Error Resume Next
'Dim ad As String
Dim x As Integer
   Dim s As Sheets

ActiveSheet.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 = ""
Sayfa1.Select
ActiveSheet.Range("A:IV").Interior.ColorIndex = xlNone
syf = ActiveWorkbook.Sheets.Count
For x = 1 To syf
If x > syf Then GoTo hst


hstbir:
If x > syf Then GoTo hst
Sheets(x).Select
ActiveSheet.Range("A:IV").Interior.ColorIndex = xlNone
Set d = ActiveSheet.Range("A:IV").Find(ad, LookIn:=xlFormulas, LookAt:=xlPart) 'Hücreye göre arar
'Set d = .Find(ad, LookIn:=xlValues, LookAt:=xlWhole) 'Kelimeye göre arar
'With Range("A:IV")
If Not d Is Nothing Then
FirstAddress = d.Address
Do

d.Rows.Select
d.Rows.Interior.ColorIndex = 3
With ActiveSheet

.Range("b" & d.Row).Interior.ColorIndex = 3
.Range("c" & d.Row).Interior.ColorIndex = 3
.Range("d" & d.Row).Interior.ColorIndex = 3
.Range("e" & d.Row).Interior.ColorIndex = 3
.Range("f" & d.Row).Interior.ColorIndex = 3
.Range("g" & d.Row).Interior.ColorIndex = 3
.Range("h" & d.Row).Interior.ColorIndex = 3
.Range("ı" & d.Row).Interior.ColorIndex = 3
.Range("j" & d.Row).Interior.ColorIndex = 3
.Range("k" & d.Row).Interior.ColorIndex = 3

End With
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 = ActiveSheet.Range("A:IV").FindNext(d)

Loop While Not d Is Nothing And d.Address <> FirstAddress
'x = ActiveSheet.Index + 1
End If
Next
If sat = 0 Then
MsgBox ad & " değeri bulunamamıştır"
Exit Sub
End If
hst:
MsgBox yer1 & Chr(10) & sat & " adet bulundu", vbInformation, "Hücrelerin numaraları"

End Sub
 

Ekli dosyalar

Bu kadar yapabilirim ....
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst