Tablodan veri bul - aktar

[bAbA_aLi]

Merhaba,

Aradığım bir kelimenin excel dosyasındaki tüm satırları bulup, bulunan satırlardaki bir kaç sütündeki veriyi başka bir excel tablosunda sıralayıp aktarmaya çalıştım.
Forumda arama sonucu aşağıdaki kodları yazarak, arama yaptığım kelimenin tüm satılarını listeledim, fakat bu satırların diğer sütün bilgilerini getiremedim. Yardımcı olur musunuz?

Sub BulListele()

Dim c As Range, Adr As Variant, sat As Long, sonhcr As Range
Dim i As Integer, adres As String
Sheets("Arama").Select
If Range("A1") = "" Then MsgBox "A1 Hücresine Aranacak Değeri Girin'": Exit Sub

sat = 2: Range("A" & sat, "A" & Rows.Count).ClearContents
For i = 1 To Worksheets.Count
If Not Sheets(i).Name = "Arama" Then
With Sheets(i).Cells
Set sonhcr = .Cells(.Rows.Count)
Set c = .Find(Range("A1"), sonhcr, xlValues, xlWhole)
If Not c Is Nothing Then
Adr = c.Address
Do
adres = Sheets(i).Name & "!" & c.Address
ActiveSheet.Cells(sat, "A").Value = Cells(1, 1).Value
sat = sat + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With
End If
Next i

Set sonhcr = Nothing: Set c = Nothing
MsgBox "Listeleme Tamam!", , "Deneme"

End Sub

 

[Erdem Akdemir]

Örnek dosya ekleyebilir misiniz?

 

[bAbA_aLi]

Sayfadan tüm bilgileri getirmeyi başardım. Buraya başka bir excel dosyasından Arama yaptığım kelimeye göre etopla işlemi ile toplam aldırıp, bu toplamın daha önceki aldığım verideki % oranlarına göre karşılığını hesaplatabilir miyiz?

Not: örnek dosya ekleyemedim!

Sub BulListele()

Dim c As Range, Adr As Variant, sat As Long, sonhcr As Range
Dim i As Integer, adres As String
Sheets("Arama").Select
If Range("A1") = "" Then MsgBox "Aranacak Değeri Girin": Exit Sub

sat = 2: Range("A" & sat, "D" & Rows.Count).ClearContents
For i = 1 To Worksheets.Count
If Not Sheets(i).Name = "Arama" Then
With Sheets(i).Cells
Set sonhcr = .Cells(.Rows.Count)
Set c = .Find(Range("A1"), sonhcr, xlValues, xlWhole)
If Not c Is Nothing Then
Adr = c.Address
Do
adres = Sheets(i).Name & "!" & c.Address
ActiveSheet.Hyperlinks.Add Cells(sat, "A"), "", adres, adres
ActiveSheet.Cells(sat, "A") = c.Offset(0, 0)
ActiveSheet.Cells(sat, "B") = c.Offset(0, 3)
ActiveSheet.Cells(sat, "C") = c.Offset(0, 10)
ActiveSheet.Cells(sat, "D") = c.Offset(0, 13)
sat = sat + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With
End If
Next i

Set sonhcr = Nothing: Set c = Nothing
MsgBox "Listeleme Tamam", , "KAYNAK HAVLU"

End Sub