Satırda bulunan değere kadar olan aralığı sütunlara aktar

[chngrcn]

Merhabalar,
Ekteki çalışmamda A sütununda saçma sapan değerler ve arada boş hücreler barındıran bir metin var.

istediğim şu,
Sayfa1 sheet'inin A sütununda bulunan "ELMA TANESİ" kelimesini bulup bir sonraki "ELMA TANESİ" kelimesine kadar olan aralığı Sayfa2 sheetinin sütunlarına yayacak..
bu iki değer arasındaki verileri ( kendileride dahil olmak üzere) sayfa2 'nin sütunlarına yayıp, satır satır halde listenelenecek..
VBA kodlaması için yardımlarınızı rica ediyorum..
Saygılar..

 

[çıtır]

Deneyiniz.

Sub satıral()
Dim ws1 As Worksheet: Dim ws2 As Worksheet
Set ws1 = Sheets("Sayfa1"): Set ws2 = Sheets("Sayfa2")
Dim i As Integer: Dim j As Integer: Dim t As Integer
Application.ScreenUpdating = False
ws2.Select
Cells.Select
    Selection.ClearContents
son = ws1.Cells(65336, "A").End(3).Row
süt = 1: sat = 1
    For i = 1 To son
     If ws2.Cells(sat, 1) = "ELMA TANESİ" And ws1.Cells(i, 1) = "ELMA TANESİ" Then
    sat = sat + 1: süt = 1
    ws2.Cells(sat, süt) = ws1.Cells(i, 1)
     süt = süt + 1
        Else
        ws2.Cells(sat, süt) = ws1.Cells(i, 1)
        süt = süt + 1
    End If
    Next i
ws2.Range("A1").select
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı", vbInformation, "BİLGİNİZE"
End Sub

 

[turist]

Alternatif dosyanız eklidir.

 

[chngrcn]

Sayın Çıtır, satır bazında yardımcı olduğunuz için,
Sayın Turist, sütun bazında alternatif yardımınız için, şahıslarınıza ayrıca teşekkür ederim. Ellerinize sağlık.

 

[turist]

Sayın Çıtır, satır bazında yardımcı olduğunuz için,
Sayın Turist, sütun bazında alternatif yardımınız için, şahıslarınıza ayrıca teşekkür ederim. Ellerinize sağlık.

Sağ olun, iyi çalışmalar.

 

[çıtır]

Sayın Çıtır, satır bazında yardımcı olduğunuz için,
Sayın Turist, sütun bazında alternatif yardımınız için, şahıslarınıza ayrıca teşekkür ederim. Ellerinize sağlık.

Rica ederim.Dönüş yaptığınız için teşekkür ederim.