Bul formülü ile ilgili düzenleme

[albatros01]

Arkadaşlar aşağıdaki düzenlemeyi satır, sayfa, hücre numarası gibi bilgileri bulmak yerine, bulunan değerin olduğu satırdaki tüm değerleri yazacak şekilde düzenleye bilirmisiniz.
Sub bul()

ad = InputBox("aranacak değeri yazınız.", "DEĞER", "")
If ad = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
sut = 2
Worksheets(ActiveSheet.Name).Columns("A:E").ClearContents
Worksheets(ActiveSheet.Name).Cells(1, 1).Value = "Sayfa Adı"
Worksheets(ActiveSheet.Name).Cells(1, 2).Value = "Hücre adresi"
Worksheets(ActiveSheet.Name).Cells(1, 3).Value = "Satır No"
Worksheets(ActiveSheet.Name).Cells(1, 4).Value = "Sutun NO"
Worksheets(ActiveSheet.Name).Cells(1, 5).Value = "Bulunan Değer"
Worksheets(ActiveSheet.Name).Cells(1, 6).Value = "Aranan Değer " & ad

For r = 1 To ActiveWorkbook.Sheets.Count
If ActiveSheet.Name <> Sheets(r).Name Then
deger = Sheets(r).Name

Set d = Worksheets(deger).Cells.Find(ad, LookIn:=xlValues)
If Not d Is Nothing Then
firstAddress = d.Address
Do
'd.Interior.ColorIndex = 3 'buradaki sayı renkleri göstermektedir.
Worksheets(ActiveSheet.Name).Cells(sut, 1).Value = Sheets(r).Name
Worksheets(ActiveSheet.Name).Cells(sut, 2).Value = d.Address
Worksheets(ActiveSheet.Name).Cells(sut, 3).Value = d.Row
Worksheets(ActiveSheet.Name).Cells(sut, 4).Value = d.Column

Worksheets(ActiveSheet.Name).Cells(sut, 5).Value = d.Value

sut = sut + 1
Set d = Worksheets(deger).Cells.FindNext(d)
Loop While Not d Is Nothing And d.Address <> firstAddress
End If

End If
Next r
MsgBox sut - 2 & " adet bulundu"
End Sub
kopyalayan bir şekle çevirebilirmiziniz.

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub bul()
Dim i       As Long
Dim c       As Range
Dim Addr    As String
Dim Ad      As String
Dim sv      As Worksheet
Dim Syf     As Integer
Set sv = Sheets("veri")
Application.ScreenUpdating = False
sv.Select
Ad = InputBox("aranacak değeri yazınız.", "DEĞER", "")
If Ad = "" Then Exit Sub
Range("A2:P65536").ClearContents
i = 1
For Syf = 1 To Sheets.Count
    If Sheets(Syf).Name <> "veri" Then
        With Worksheets(Syf).Range("a:p")
            Set c = .Find(Ad, LookIn:=xlValues[B][COLOR=red], LookAt:=xlWhole[/COLOR][/B])
            If Not c Is Nothing Then
                Addr = c.Address
                Do
                    i = i + 1
                    Sheets(Syf).Range("A" & c.Row & ":P" & c.Row).Copy Range("A" & i)
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Addr
            End If
        End With
    End If
Next Syf
Application.ScreenUpdating = True
End Sub

 

[ileri]

Peki Birşey sorucam buttondan sayfa 3 de secili alanları nasıl yazdıra bilirim

 

[albatros01]

Çok teşekkür ederim Necdet Bey, sağolun. İstediğim gibi olmuş. Ancak ilk yazılımda arama yaptırırken Ankara yerine Ank yazdırıp ara deyince değerleri buluyordu. Şimdi kelimenin tamamını yazmam gerekiyor. Bu durum numaralar içinde aynı 39947 yerine 399 yazınca hepsini getiriyordu. Böyle bir düzeltme yaparsanız inanın çok sevinirim. Şu hali ile bile işimi çok kolaylaştırdı.

Sizin de işlerinizin hep kolay ve yolunda gitmesi temennisiyle iyi çalışmalar diliyorum.

 

[Necdet]

Merhaba,

Koddaki Set c = .Find(Ad, LookIn:=xlValues, LookAt:=xlWhole) satırından kırmızı yazılanları silerek

Set c = .Find(Ad, LookIn:=xlValues) şekline getiriniz.

 

[albatros01]

teşekkürler Necdet Bey istediğim gibi oldu.