Karışık bir listeden sadece istenilen verileri almak

[metehancan]

Sayfa1' deki bazı bilgileri Sayfa2 'deki şekle çevirmek istiyorum.
Sayfa1' de orta öğretim ve yüksek öğretim olmak üzere iki tür yurt var. Sayfa2' ye sadece orta öğretim yurtdlarının isimlerini ve telefonunu aktarmasını istiyorum. Yüksek öğretim yurtları işime yaramadığı için ayfa2 ye aktarılmasına gerek yok. Yardımlarınızı bekliyorum

 

[Ömer]

Merhaba,

Module kopyalayarak çalıştırınız.

Sub Listele()
 
Dim i As Long, sat As Long, S1 As Worksheet
 
Set S1 = Sheets("Sayfa1")
 
Application.ScreenUpdating = False
 
Sheets("Sayfa2").Select
Range("A2:B" & Rows.Count).ClearContents
 
sat = 2
For i = 4 To S1.Cells(Rows.Count, "A").End(xlUp).Row
    If S1.Cells(i, "A") Like "*ORTA ÖĞRETİM*" Then
        Cells(sat, "A") = S1.Cells(i, "A")
        Cells(sat, "B") = S1.Cells(i + 1, "D")
        sat = sat + 1
    End If
Next i
 
Application.ScreenUpdating = True
 
End Sub

.

 

[metehancan]

Hocam beni yine büyük dertlerden kurtardınız. Allah sizden razı olsun.

 

[Mehmet Şahin]

Merhaba,
Ömer beyin kodları yanında alternatif olsun.
İyi geceler.

Sub yurt_bul()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = ThisWorkbook.Sheets("Sayfa1")
Set sh2 = ThisWorkbook.Sheets("Sayfa2")
sn1 = sh1.Cells(65536, 1).End(xlUp).Row
sn2 = sh2.Cells(65536, 1).End(xlUp).Row + 1
Application.ScreenUpdating = False
   sh2.Range("a2:b" & sn2).ClearContents
   sn2 = 2
       For i = 4 To sn1
          If UCase(Trim(sh1.Cells(i, "a"))) = "KODU" Then
              If InStr(1, sh1.Cells(i - 1, "a"), "ORTA", vbTextCompare) > 0 Then
                sh2.Cells(sn2, "a") = sh1.Cells(i - 1, "a")
                sh2.Cells(sn2, "b") = sh1.Cells(i, "d")
                sn2 = sn2 + 1
               End If
           End If
       Next i
Application.ScreenUpdating = True
Set sh1 = Nothing: Set sh2 = Nothing
End Sub