Bul ve sayfa 2 ye ekle

[ziraatci26]

Değişik bir, bul ve ekle olayı

Pdf den çevirdiğim bir dosya var elimde ver.İçerisindeki veriyi kod numaralarına göre süzüp diğer sayfalaya eklemek istiyorum.dosya ektedir.yardımcı olursanız sevinirim.

 

[Ferhat Pazarçevirdi]

Merhabalar

Ekteki kodları, standart bir modül sayfasına kopyalayıp, çalıştırınız.

 Sub Duzenle()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim bul As Range
Dim Baslangic_Satir As Long
Dim Sh2SonSatir As Long
Dim adres As String
Dim i As Long
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
sh2.Range("A2:E" & sh2.Cells(65536, 1).End(xlUp).Row).ClearContents
Set bul = sh1.Columns(1).Find("Soyadi", , , xlPart)
If Not bul Is Nothing Then
   adres = bul.Address
   Do
      Baslangic_Satir = bul.End(xlDown).Row + 1
      For i = Baslangic_Satir To 65536
          If IsEmpty(sh1.Cells(i, 1)) = True Then: Exit For
          Sh2SonSatir = sh2.Cells(65536, 1).End(xlUp).Row + 1
          With sh2
             .Cells(Sh2SonSatir, 1) = bul.Offset(-1, 1)
             .Cells(Sh2SonSatir, 2) = bul.Offset(0, 1)
             .Cells(Sh2SonSatir, 3) = sh1.Cells(i, 1)
             .Cells(Sh2SonSatir, 4) = sh1.Cells(i, 2)
             .Cells(Sh2SonSatir, 5) = sh1.Cells(i, 3)
          End With
      Next i
      Set bul = sh1.Columns(1).FindNext(bul)
   Loop While Not bul Is Nothing And bul.Address <> adres
End If
Set sh1 = Nothing
Set sh2 = Nothing
Set bul = Nothing
End Sub

 

[ziraatci26]

Hocam emeğine sağlık çok teşekkür ederim.Takıldığım bi nokta var.ekteki dosyada açıkladım.yardımcı olursan sevinirim.

 

[Ferhat Pazarçevirdi]

Dosyanızın orjinal şeklini içinde birkaç örnekle birlikte ekleyiniz.

Zira 3 Nolu mesajınızdaki örnekten A'ların ve B'leri, hangi satır ve sütunlara kadar sürdüğünü anlayamıyorum.

 

[ziraatci26]

hocam örnek ektedir.Yardımlarını bekliyorum

 

[Ferhat Pazarçevirdi]

Aşağıdakileri standart bir modül sayfasına kopyalayarak çalıştırınız.

Sub Duzenle()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim bul As Range
Dim Baslangic_Satir As Long
Dim Sh2SonSatir As Long
Dim adres As String
Dim i As Long, k As Long
Dim x As Integer, j As Integer
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
If sh2.Cells(65536, 1).End(xlUp).Row > 1 Then
   sh2.Range("A2:AW" & sh2.Cells(65536, 1).End(xlUp).Row).ClearContents
End If
Set bul = sh1.Columns(1).Find("Soyadi", , , xlPart)
If Not bul Is Nothing Then
   adres = bul.Address
   Do
      Baslangic_Satir = bul.Offset(23, 0).Row + 1
      For i = Baslangic_Satir To 65536
          If IsEmpty(sh1.Cells(i, 1)) = True Then: Exit For
          Sh2SonSatir = sh2.Cells(65536, 1).End(xlUp).Row + 1
          For k = bul.Row - 1 To bul.Row + 22
              x = x + 1
              sh2.Cells(Sh2SonSatir, x) = sh1.Cells(k, 2)
          Next k
          x = 0
          For j = 25 To 49
              x = x + 1
              sh2.Cells(Sh2SonSatir, j) = sh1.Cells(i, x)
          Next j
          x = 0
      Next i
      Set bul = sh1.Columns(1).FindNext(bul)
   Loop While Not bul Is Nothing And bul.Address <> adres
End If
Set sh1 = Nothing
Set sh2 = Nothing
Set bul = Nothing
End Sub

 

[ziraatci26]

hocam çok sağol eline sağlık