sütunda istenilen veriye rastlanınca Sheet1 e yazdırma

[netislem]

amaçladığım b sütununda belirteceğim kodun yer alması durumunda mevcut satırın tamamını Sheet1 e yazdırabilmek bu konuda yardımcı olabilirseniz minnettar olurum şimdiden teşekkürler
syg

 

[Ömer]

Merhaba,

Module kopyalarak çalıştırınız. Kırmızı bölgeyi istediğiniz ölçüte göre değiştirirsiniz.

Sub AraYaz()
 
    Dim c As Range, ilkadres As Variant, Sc As Worksheet
    Dim sat As Long, Aranan_Deger
 
    Set Sc = Sheets("(1) Select crd_courier")
 
    Application.ScreenUpdating = False
    Sheets("Sheet1").Select
 
    Cells.Clear
    Sc.Range("A1", Sc.Cells(1, Columns.Count)).Copy Range("A1")
 
    [COLOR=blue]Aranan_Deger[/COLOR] = "[COLOR=red]510[/COLOR]"
 
    sat = 2
    With Sc.Range("B:B")
        Set c = .Find(Aranan_Deger, LookAt:=xlPart)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                Sc.Rows(c.Row).Copy Range("A" & sat)
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
    Application.ScreenUpdating = True
 
End Sub

.

 

[netislem]

peki çoklu seçenek istersem ne yapmalıyım 004,510,545 gibi birden fazla statüyü içeren satırı bulması halinde sheet1 e yazdırmak istersem ne yapmalıyım?
teşekkürler

 

[netislem]

yardımcı olabilecek arkadaşlar şimdiden teşekkürler

 

[Ömer]

Bu şekilde deneyiniz.

Sub AraYaz()
 
    Dim c As Range, ilkadres As Variant, Sc As Worksheet
    Dim sat As Long, i As Long, Aranan_Deger As String, AranacakOlanlar
 
    Set Sc = Sheets("(1) Select crd_courier")
 
    Application.ScreenUpdating = False
    Sheets("Sheet1").Select
 
    Cells.Clear
    Sc.Range("A1", Sc.Cells(1, Columns.Count)).Copy Range("A1")
 
    [COLOR=blue]AranacakOlanlar = Array("[COLOR=red]510[/COLOR]", "[COLOR=red]004[/COLOR]", "[COLOR=red]545[/COLOR]")
[/COLOR]
    sat = 2
    For i = 0 To UBound(AranacakOlanlar)
        Aranan_Deger = AranacakOlanlar(i)
        With Sc.Range("B:B")
            Set c = .Find(Aranan_Deger, LookAt:=xlPart)
            If Not c Is Nothing Then
                ilkadres = c.Address
                Do
                    Sc.Rows(c.Row).Copy Range("A" & sat)
                    sat = sat + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> ilkadres
            End If
        End With
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.