Bul Ve Değiştirden Kopyalama Yapmak

[kanarya_83]

Merhabalar,

Öncelikle bu sitede emeği geçenlere sonsuz teşekkür ediyorum. Gerçekten bir çok konuda faydalandım.

Sorum: 58 sayfadan oluşan bir çalışma kitabım var. bu kitapta ctrl+f tuşu ile bir kişi ismi arıyorum ve sonuçlar listeleniyor. Ben bu listede çıkan verileri bulunduğu satırla beraber kopyalayabilirmiyim. Bunun için bir çözümünüz varmı?

Yardımlarınız için peşinen teşekkürlerimle,

 

[Orion1]

Bir userform oluşturunuz.
Bul kodlarını (find) kullanarak bir listbox'ta bulunan isimlerin hücre adreslerini yazınız.Ve oradan seçerek kopyala butonu ile kopyalama yapınız.

 

[kanarya_83]

yardımınız için teşekkürler fakat ben yazdıklarınızı yapamadım malesef. Ekteki dosyadaki ARMANDO MANZANERO isminin geçtiği full satırlar lazım. yani sağ ve sol yanlarındakiler. Yardımcı olursanız sevinirim

 

[Orion1]

Dosyanızı Excel-2003 (xls) versiyonunda gönderiniz.
Çoğu kimsede 2007 versiyonu yok.

 

[kanarya_83]

Tekrar ekledim.

teşekkürler,

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz. Sarı renkli hücreye aramak istediğiniz veriyi yazıp butona basın.

 

[kanarya_83]

Çok Teşekkür ederim. Tam istediğim bi çalışma olmuş. Emekleriniz için sonsuz teşekkürler.

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodu kullanabilirsiniz.

Standart bir modül sayfasına kopyalayarak çalıştırınız.

Option Explicit
Sub Bulalim()
    Dim Bul As Range
    Dim adres As String
    Dim sh As Worksheet
    Dim arr()
    Dim Aranan As String
    Dim y%, i%
f1:
    
    Aranan = InputBox("Aranan Değeri girinizi", "Bul")
    If Aranan = vbNullString Then
        If MsgBox("Boş değer girdiniz, bir değer girerek denemek ister misiniz ?", vbYesNo + vbCritical, "Uyarı") = vbYes Then
            GoTo f1
        Else
            Exit Sub
        End If
    End If
    
    For Each sh In ThisWorkbook.Worksheets
        Set Bul = sh.Cells.Find(What:=Aranan, _
                                Lookat:=xlWhole)
        If Not Bul Is Nothing Then
            adres = Bul.Address
            Do
                y = y + 1
                ReDim Preserve arr(1 To 2, 1 To y)
                arr(1, y) = sh.Name
                arr(2, y) = Bul.Row
                Set Bul = sh.Cells.Find(What:=Aranan, After:=Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> adres
        End If
    Next
    
    On Error Resume Next
    If MsgBox("Toplam : " & UBound(arr, 2) & _
                          " adet kayıt bulundu. Yazdırılsın mı?", _
               vbYesNo + vbExclamation, _
              "Yazdırma") = vbYes Then
        If Err.Number <> 0 Then
            If MsgBox("Aranan değerle karşılaşılmadı. Yeni arama yapılsın mı?", vbYesNo + vbCritical, "Uyarı") = vbYes Then
                GoTo f1
            Else
                Set Bul = Nothing
                Exit Sub
            End If
        End If
        On Error GoTo 0
        
        Workbooks.Add
        
        Range("A1:Z1").Value = ThisWorkbook.Sheets(1).Range("A4:Z4").Value
        Range("A2:Z2").Value = ThisWorkbook.Sheets(1).Range("A5:Z5").Value
        
        With Application
            .ScreenUpdating = False
            .Calculation = xlCalculationManual
            
            For i = 1 To UBound(arr, 2)
                Range("A" & i + 2 & ":Z" & i + 2).Value = ThisWorkbook.Sheets(arr(1, i)). _
                                                                Range("A" & arr(2, i) & ":Z" & arr(2, i)).Value
            Next i
            
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
        End With
    
    End If
    Set Bul = Nothing
    
End Sub