Vba Kod Yardımı

[Mehmet Sait]

Merhabalar,

Bir sayyfada içerdiği metne göre arama yapmak için ekli kodda nasıl değişim yapmalıyım

[KOD] Alt BUL2 ()
Dize Olarak Dim DEG
Hatada HATA'ya Git
'Aralık ("B1: B1000"). Interior.ColorIndex = xlNone
DEG = InputBox ("Aranacak veriyi giriniz.")
Cells.Find (DEG, LookIn: = xlValues, lookat: = xlWhole) .Select
Aralık (Seçim, Seçim. Ofset (0, 2)). Interior.ColorIndex = 6
HATA:
Err Öyleyse
MsgBox "Aradığınız değer bulundu."
Bittiğinde
Son Alt


[/ KOD]

Teşekkür ederim

 

[kulomer46]

Konuyla ilgili Hazır Program Ek'tedir.

İlgilenenler için adım adım yapılanlar 1. Adım ve 2. adım olarak aşağıda yazılmıştır.

1. Adım

Aşağıdaki kod bloğunu excel kod kısmında Insert Module diyerek açılan modul sayfasına ekleyiniz. Bu kod, arama yapmanızı ve arama sonuçlarını 'Aranan Kelime Raporu' sayfasında raporlamanızı sağlar.

Sub Tüm_Sayfalar_İçin_Aranan_Kelime_Raporu()
'17.12.2018 saat 10:40

bul1 = ""
bul1 = InputBox("Tüm Sayfalarda Aramak İstediğiniz Metni Giriniz", , "ahmet")

If Trim(bul1) = "" Then

MsgBox "Herhangi Bir Değer Girmediniz.", , " Microsoft Excel - Hiç Değer Girilmedi"
End

End If

bulduk = 0

buldukgel:
If bulduk = 1 Then

For ii = 1 To Worksheets.Count

If Worksheets(ii).Name = "Aranan Kelime Raporu" Then
Worksheets(ii).Cells.Clear
GoTo uç3
End If

Next

Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Aranan Kelime Raporu"
uç3:

Worksheets("Aranan Kelime Raporu").Cells(1, 1) = "Aranan Metin"
Worksheets("Aranan Kelime Raporu").Cells(2, 1) = bul1
Worksheets("Aranan Kelime Raporu").Cells(2, 1).Font.Bold = True
Worksheets("Aranan Kelime Raporu").Cells(2, 1).Font.Color = RGB(192, 0, 0)

Worksheets("Aranan Kelime Raporu").Cells(4, 1) = "Arama Sonuçları Aşağıdadır"
Range(Worksheets("Aranan Kelime Raporu").Cells(4, 1), Worksheets("Aranan Kelime Raporu").Cells(4, 3)).Merge
Range(Worksheets("Aranan Kelime Raporu").Cells(4, 1), Worksheets("Aranan Kelime Raporu").Cells(4, 3)).Font.Bold = True
Range(Worksheets("Aranan Kelime Raporu").Cells(4, 1), Worksheets("Aranan Kelime Raporu").Cells(4, 3)).HorizontalAlignment = xlCenter
Range(Worksheets("Aranan Kelime Raporu").Cells(4, 1), Worksheets("Aranan Kelime Raporu").Cells(4, 3)).Interior.Color = RGB(255, 192, 0)


Worksheets("Aranan Kelime Raporu").Cells(5, 1) = "Sayfa Adı"
Worksheets("Aranan Kelime Raporu").Cells(5, 2) = "Hücre Adresi"
Worksheets("Aranan Kelime Raporu").Cells(5, 3) = "Bulunduğu yerde Tam Hücre İçeriği"
Range(Worksheets("Aranan Kelime Raporu").Cells(5, 1), Worksheets("Aranan Kelime Raporu").Cells(5, 3)).Font.Bold = True
Range(Worksheets("Aranan Kelime Raporu").Cells(5, 1), Worksheets("Aranan Kelime Raporu").Cells(5, 3)).Font.Color = RGB(0, 112, 192)

Worksheets("Aranan Kelime Raporu").Columns("A:A").ColumnWidth = 12
Worksheets("Aranan Kelime Raporu").Columns("B:B").ColumnWidth = 18
Worksheets("Aranan Kelime Raporu").Columns("C:C").ColumnWidth = 35

End If

For i = 1 To Worksheets.Count

If Worksheets(i).Name <> "Aranan Kelime Raporu" Then

''' If bulduk = 1 Then MsgBox Worksheets(i).Name

For satir1 = 1 To Worksheets(i).UsedRange.Row + Worksheets(i).UsedRange.Rows.Count - 1
For sütun1 = 1 To Worksheets(i).UsedRange.Row + Worksheets(i).UsedRange.Columns.Count - 1

For j = 1 To Len(Worksheets(i).Cells(satir1, sütun1))

If UCase(Mid(Worksheets(i).Cells(satir1, sütun1), j, Len(bul1))) = UCase(bul1) Then

If bulduk = 0 Then
bulduk = 1
GoTo buldukgel
End If

Worksheets("Aranan Kelime Raporu").Select

DoEvents

Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row + 1, 1) = Worksheets(i).Name
Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 1).Font.Bold = True

Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 2) = Replace(Cells(satir1, sütun1).AddressLocal, "$", "")
Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 2).Font.Bold = True
Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 2).HorizontalAlignment = xlCenter

Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 3) = Worksheets(i).Cells(satir1, sütun1)

Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 4) = "Seç"
Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 4).Font.Bold = True
Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 4).HorizontalAlignment = xlCenter
Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 4).Font.Color = RGB(192, 0, 0)

If Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row Mod 9 = 0 Then Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 1).Select

For jjj = 1 To Len(Cells(Cells(Rows.Count, 1).End(3).Row, 3))

If UCase(Mid(Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 3), jjj, Len(bul1))) = UCase(bul1) Then

Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 3).Characters(jjj, Len(bul1)).Font.Bold = True
Worksheets("Aranan Kelime Raporu").Cells(Worksheets("Aranan Kelime Raporu").Cells(Rows.Count, 1).End(3).Row, 3).Characters(jjj, Len(bul1)).Font.Color = RGB(192, 0, 0)

End If

Next

GoTo birtanebulduk

End If

Next

birtanebulduk:

Next
Next

End If

Next


If bulduk = 0 Then

MsgBox "Girilen " & bul1 & " metni Bu Çalışma Kitabında Bulunmamaktadır.", , " Girilen Metin Bulunamadı"
End

End If

Cells.EntireColumn.AutoFit
If Columns("C:C").ColumnWidth > 63 Then Columns("C:C").ColumnWidth = 63
Columns("D").ColumnWidth = 5

Cells(4, 1).Select

'Cells(1, 3) = "Arama Tamamlandı."
'Cells(2, 3) = Cells(Rows.Count, 1).End(3).Row - 5 & " hücre bulundu"

MsgBox "Aranan Metin : " & bul1 & Chr(10) & Chr(10) & Cells(Rows.Count, 1).End(3).Row - 5 & " hücre bulundu" & Chr(10) & "Arama Tamamlandı", , " Microsoft Excel - Mutluluk Sizinle Olsun"

End Sub



2. Adım

'Aranan Kelime Raporu' sayfasında D sütununda 'seç' yazılı hücre tıklandığında, ilgili sayfanın ilgili satırını otomatik seçmek içinde aşağıdaki kod bloğunu, Çalışacağınız Excel Çalışma Kitabı' nızın Kod bölümünde bulunan BuÇalışmaKitabı alanı Workbook_SheetSelectionChange kısmına yapıştırmanız yeterlidir.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Application.ActiveSheet.Name = "Aranan Kelime Raporu" Then

If Target.Column = 4 Then

If Target.Row > 5 And Target.Value = "Seç" Then


sayfaadi = Trim(Target.Offset(0, -3).Value)

If sayfaadi = "" Then MsgBox "Sayfa Adı Alanı Boş": End

satırsütun = Trim(Target.Offset(0, -2).Value)

If satırsütun = "" Then MsgBox "Hücre Adresi Alanı Boş": End


For i = 1 To Worksheets.Count

If Worksheets(i).Name = sayfaadi Then


Worksheets(sayfaadi).Select

On Error GoTo hata1

'''Gidilecek hücre adresi Geçerli Bir Hücre Adresi olmaması durumunda aşağıdaki 3 satır kod ile bilgisayar oyalanmakta ve bu arada bilgisayarın Girilen Adres Geçerli Bir Hücre Adresi Değildir mesajı vermesi sağlanmaktadır.

ali = Range(satırsütun).Value
veli = ali
selami = veli


Range(satırsütun).Select
GoTo ensonburası


hata1:

Worksheets("Aranan Kelime Raporu").Select
MsgBox satırsütun & " Geçerli Bir Hücre Adresi Değildir"
GoTo ensonburası


End If

Next

MsgBox sayfaadi & " adlı sayfa bulunamadı"



End If

End If

End If



ensonburası:
End Sub

 

[Mehmet Sait]

kulomer46 hocam

Teşekkür ederim. Emeğinize sağlık.

 

[kulomer46]

kulomer46 hocam

Teşekkür ederim. Emeğinize sağlık.

Selamlar...

 

[Mehmet Sait]

Selamlar...

Merhaba Hocam,

Verdiğiniz kodları sayfaya uyarlayamadım.

 

[Mahmut Bayram]

dosyanız ektedir.

 

[Mehmet Sait]

Merhaba,
Elinize sağlık çok güzel olmuş. D sütununda " Seç " çıkıyor ama işlem yapmıyor.

 

[kulomer46]

Merhaba
Dosyanızın son hali Ek' tedir. D sütununda "Seç" tıklandığında ilgili sayfanın ilgili hücresi otomatikmen seçilmektedir.
İlgilenenler için yukardaki #2 (Mesaj 2'de) konuyla ilgili açıklama yapılmıştır.

 

[Mehmet Sait]

Teşekkür ederim.

 

[kulomer46]

Teşekkür ederim.

Selamlar..