Tüm sayfalarda ara bul

[ASLAN7410]

Merhaba hayırlı geceler.

Ekte gönderdiğim excel dosyamın VERİ isimli sayfasının A2 hücresine yazmış olduğum her hangi bir veriyi,
bu sayfa hariç diğer sayfalarda bulduğunda B2 hücresinden aşağıya doğru yazmasını ve köprü oluşturmasını istiyorum.

Ctrl+F bu işi yapıyor ancak bulmak istediğim veriler bazen çok olduğu zaman zaman alıyor.

Yardımcı olur musunuz?
.

 

[halit3]

kod:

Sub bul()

Dim aranan, i, j, sut, sat, say, deg1, yer

Application.ScreenUpdating = False

Worksheets("VERİ").Range(Worksheets("VERİ").Cells(2, "b"), Worksheets("VERİ").Cells(Rows.Count, "d")).ClearContents
Worksheets("VERİ").Range(Worksheets("VERİ").Cells(2, "b"), Worksheets("VERİ").Cells(Rows.Count, "d")).Font.ColorIndex = 0
Worksheets("VERİ").Range(Worksheets("VERİ").Cells(2, "b"), Worksheets("VERİ").Cells(Rows.Count, "d")).Hyperlinks.Delete

sat = 2

For r = 2 To Worksheets("VERİ").Cells(Rows.Count, "A").End(3).Row


If Worksheets("VERİ").Cells(r, 1).Value <> "" Then

For n = 1 To ActiveWorkbook.Sheets.Count
'If ActiveSheet.Name <> Sheets(n).Name Then
If "VERİ" <> Sheets(n).Name Then
If WorksheetFunction.CountA(Worksheets(Sheets(n).Name).Cells) > 0 Then
' Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut1 = Worksheets(Sheets(n).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Else
sut1 = 1
End If
sut = "B"

yer = Worksheets(Sheets(n).Name).Range(Worksheets(Sheets(n).Name).Cells(1, "a"), Worksheets(Sheets(n).Name).Cells(Rows.Count, sut1)).Address
aranan = Worksheets("VERİ").Cells(r, 1).Value

With Worksheets(Sheets(n).Name).Range(yer)
Set d = .Find(aranan, .Cells(.Cells.Count), xlFormulas, xlPart)
If Not d Is Nothing Then
FirstAddress = d.Address
Do

deg1 = 0
say = 0
For j = 1 To Len(d.Value)
i = InStr(j, d.Value, aranan, vbTextCompare)
If i > 0 Then
say = say + 1
If say = 1 Then
Sheets("VERİ").Cells(sat, "d").Value = d.Value
Sheets("VERİ").Cells(sat, "d").NumberFormat = "@"
Sheets("VERİ").Cells(sat, "c").Value = Sheets(n).Name
Sheets("VERİ").Cells(sat, "b").Hyperlinks.Add Anchor:=Sheets("VERİ").Cells(sat, "b"), Address:="", SubAddress:=Sheets(n).Name & "!" & d.Address, TextToDisplay:=d.Address
End If
'Sheets("VERİ").Cells(sat, "b").Characters(Start:=i, Length:=Len(aranan)).Font.ColorIndex = 3
deg1 = 1
End If
Next
If deg1 > 0 Then
sat = sat + 1
End If

Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With

End If
Next
End If
Next r
MsgBox "işlem tamama"
Application.ScreenUpdating = True

End Sub

 

[ASLAN7410]

Sayın Halit Bey, ellerinize sağlık tam istediğim gibi olmuş.

Hayırlı günler, hayırlı çalışmalar diliyorum.

 

[ASLAN7410]

Sayın Halit bey, tekrar rahatsız ediyorum. Yazmış olduğunuz kod göndermiş olduğum örnekte gayet güzel çalışıyor.
Kodu iş yerindeki orijinal dosyamda uyguladığım plakaları buluyor, oluşturmuş olduğu köprüye tıkladığımda ekte
gönderdiğim hata mesajını alıyorum plakayı bulduğu sayfaya gitmiyor.
.

 

[halit3]

Neden olduğunu bilmiyorum orjinal dosyanızı görmek lazım
iş yerindeki bilgisayarlar kısıtlı mı

 

[ASLAN7410]

Aynı dosyayı bu bilgisayara da kopyalıyorum, bu bilgisayarda da aynı hatayı veriyor.

 

[ASLAN7410]

Her iki bilgisayarda da Ofis 2013 Türkçe yüklü.

 

[halit3]

Dosyayı görmek lazım

 

[ASLAN7410]

Halit Bey, hazırladığım örnek dosya ekte.
.

 

[ASLAN7410]

Sayın Halit Bey, dosyadaki sayfa isimlerini bitişik yazdığımda yazmış olduğunuz kod çalışıyor.
Örneğin sayfa adı TAKİPTEKİ ARAÇLAR'ı bitişik şekilde yazdığım zaman çalışıyor. Bunu düzeltirseniz sanırım istediğim sonuç alınacak.

 

[ASLAN7410]

Dosyayı ortak kullandığımız için sayfa isimlerini her arkadaş farklı şekilde yazıyor. Kimisi tek bir isim, kimisi bir kaç kelime şeklinde yazıyorlar.

Yazmış olduğunuz kod da bir kelime haricindeki sayfaları görmüyor.

 

[ASLAN7410]

Sayın Halit Bey, ekte gönderdiğim örnek dosyada CCCC sayfası diye bulduğu veriye tıkladığımda imleç o sayfaya gidiyor, diğer sayfalara gitmiyor.

 

[halit3]

Kırmızı tırnak işaretleri eklendi


KOD:

Sub PlakaBul()

Dim aranan, i, j, sut, sat, say, deg1, yer

Application.ScreenUpdating = False

Worksheets("SERVET").Range(Worksheets("SERVET").Cells(2, "b"), Worksheets("SERVET").Cells(Rows.Count, "d")).ClearContents
Worksheets("SERVET").Range(Worksheets("SERVET").Cells(2, "b"), Worksheets("SERVET").Cells(Rows.Count, "d")).Font.ColorIndex = 0
Worksheets("SERVET").Range(Worksheets("SERVET").Cells(2, "b"), Worksheets("SERVET").Cells(Rows.Count, "d")).Hyperlinks.Delete

sat = 2

For r = 2 To Worksheets("SERVET").Cells(Rows.Count, "A").End(3).Row


If Worksheets("SERVET").Cells(r, 1).Value <> "" Then

For n = 1 To ActiveWorkbook.Sheets.Count
'If ActiveSheet.Name <> Sheets(n).Name Then
If "SERVET" <> Sheets(n).Name Then
If WorksheetFunction.CountA(Worksheets(Sheets(n).Name).Cells) > 0 Then
' Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut1 = Worksheets(Sheets(n).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Else
sut1 = 1
End If
sut = "B"

yer = Worksheets(Sheets(n).Name).Range(Worksheets(Sheets(n).Name).Cells(1, "a"), Worksheets(Sheets(n).Name).Cells(Rows.Count, sut1)).Address
aranan = Worksheets("SERVET").Cells(r, 1).Value

With Worksheets(Sheets(n).Name).Range(yer)
Set d = .Find(aranan, .Cells(.Cells.Count), xlFormulas, xlPart)
If Not d Is Nothing Then
FirstAddress = d.Address
Do

deg1 = 0
say = 0
For j = 1 To Len(d.Value)
i = InStr(j, d.Value, aranan, vbTextCompare)
If i > 0 Then
say = say + 1
If say = 1 Then
Sheets("SERVET").Cells(sat, "d").Value = d.Value
Sheets("SERVET").Cells(sat, "d").NumberFormat = "@"
Sheets("SERVET").Cells(sat, "c").Value = Sheets(n).Name

Sheets("SERVET").Cells(sat, "b").Hyperlinks.Add Anchor:=Sheets("SERVET").Cells(sat, "b"), Address:="", SubAddress:=[COLOR="red"]"'" &[/COLOR] Sheets(n).Name & "[COLOR="Red"]'[/COLOR]!" & d.Address, TextToDisplay:=d.Address
End If
'Sheets("SERVET").Cells(sat, "b").Characters(Start:=i, Length:=Len(aranan)).Font.ColorIndex = 3
deg1 = 1
End If
Next
If deg1 > 0 Then
sat = sat + 1
End If

Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With

End If
Next
End If
Next r
MsgBox "İşlem tamam.", vbInformation, "ASLAN"
Application.ScreenUpdating = True

End Sub

 

[ASLAN7410]

Sayın Halit Bey, hayırlı sabahlar.

Ellerinize sağlık, valla süper oldu, çok teşekkür ediyorum.

Hayırlı çalışmalar diliyorum.