veri buldurup yanındaki 75 sütunla kopyalama

[yavuzoz]

arkadaşlar bu forumu inceleyerek bulduğum bir kod üzerinde biraz değişiklik yaparak aşağıdaki hale getirdim, ancak bu kod sadece aradığım metin hücresinin adresini getiriyor oysa ben tam olarak şunu istiyorum,

iki sayfalı çalışma kitabının 1.sayfasının a1 hücresindeki metni, 2.sayfanın b sütununda aratıp (ki bu metin birden fazla olabilir) yanında ki 75 sütunla birlikte bulunduğum sayfaya yazması (A sütunundan CC sütununa kadar)


Sub BulListele12()

Dim c As Range, Adr As Variant, sat As Long, sonhcr As Range
Dim i As Integer, adres As String

sat = 20: i = 2

With Sheets(i).Cells
Set sonhcr = .Cells(.Cells.Count)
Set c = .Find(Range("A1"), sonhcr, xlValues, xlWhole)
If Not c Is Nothing Then
Adr = c.Address
Do
adres = c.Address
Cells(sat, "A") = adres
sat = sat + 1
Set c = .FindNext(c)

Loop While Not c Is Nothing And c.Address <> Adr
End If
End With

Set sonhcr = Nothing: Set c = Nothing

End Sub



yardımcı olacak arkadaşlara çok teşekkür ederim..

 

[İhsan Tank]

Dosya ekler misiniz_?

 

[yavuzoz]

Ekli dosyayı görüntüle deneme.xls ekledim ..

 

[İhsan Tank]

Ekli dosyayı görüntüle 119611 ekledim ..

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub kriterli_arama_61()
Dim ts, kaplan, trabzonspor, hamsi As Date
Dim bordo, mavi
Set bordo = Sheets("Sayfa1")
Set mavi = Sheets("Sayfa2")
If bordo.Range("A1") = Empty Then
MsgBox "Kriter Boş", vbCritical, "Hata"
bordo.Select
bordo.Range("A1").Select
Exit Sub
End If
trabzonspor = MsgBox(bordo.Range("A1") & vbLf _
& " Karşılıklarını Aktarıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
bordo.Range(Rows(2).Address & ":" & Rows(Rows.Count) _
.Address).Delete
kaplan = 2
For ts = 1 To mavi.Cells(Rows.Count, "B").End(xlUp).Row
If mavi.Cells(ts, "B") = bordo.Range("A1") Then
mavi.Rows(ts).Copy Destination:=bordo.Range("A" & kaplan)
kaplan = kaplan + 1
End If
Next
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & " Sürede" & vbLf _
& bordo.Range("A1") & " Karşılığını Aktardım", , "Bitiş"
End Sub

 

[yavuzoz]

üstadım eline sağlık çok teşekkür ederim...

 

[İhsan Tank]

üstadım eline sağlık çok teşekkür ederim...

Rica ederim
:keyif:

 

[yavuzoz]

üstadım tekrar merhaba
aslında bu kod işi görüyor ancak kopyalanan hücreyi olduğu gibi alıyor.
sadece hücrede ki değerleri aldıramazmıyız, yani hedef hücrelerin biçimlerini değilde sadece içinde ki değerleri demek istiyorum..
sağlık ve mutluluk dilerim...

 

[İhsan Tank]

üstadım tekrar merhaba
aslında bu kod işi görüyor ancak kopyalanan hücreyi olduğu gibi alıyor.
sadece hücrede ki değerleri aldıramazmıyız, yani hedef hücrelerin biçimlerini değilde sadece içinde ki değerleri demek istiyorum..
sağlık ve mutluluk dilerim...

Bu şekilde yaptığımızda kod çok uzayacaktır. Çünkü Yaklaşık olarak 23 sütundaki verileri ayrı ayrı alması gerekecek

 

[yavuzoz]

tamamdır, tekrar teşekkürler...

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak aşağıdaki kod ile sadece değerleri aktarabilirsiniz.

Sub BUL_LİSTELE()
    Dim S1 As Worksheet, S2 As Worksheet, Satır As Integer
    Dim BUL As Range, ADRES As String, Kriter As String
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Kriter = S1.Range("A1")
    Satır = 20
    S1.Range("A2:CC" & Rows.Count).ClearContents
    
    Set BUL = S2.Range("B:B").Find(Kriter, , , xlWhole)
    If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            S1.Range("A" & Satır & ":CC" & Satır).Value = _
            S2.Range("A" & BUL.Row & ":CC" & BUL.Row).Value
            Satır = Satır + 1
            Set BUL = S2.Range("B:B").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub