Macro ile çoklu satır taşıma problemi hakkında

[hamza2011]

Ek' li dosyada paylaştığım ve ricamı dosya içerisine yazdığım konu hakkında yardım eder misiniz lütfen!

 

[Muzaffer Ali]

Merhaba.

"A sütunundaki "Y" ile başlayan satırları "E"ile başlayan satıralarına karşılık gelen yerlerine taşımak istiyorum." demişsiniz.
Bu karşılaştırmayı neye(hangi kriterlere) göre yapacağız?

 

[hamza2011]

Hocam Örneğin; 5. satırda "Y" olan satırı (satırdaki bilgileri) bir üstündeki 4.satırın (E olan) sonuna eklemek istiyorum.
"2.ÖRNEK DOSYA" da belirtmek istediğim gibi.

 

[Muzaffer Ali]

Aşağıdaki kodları sayfanın kod bölümüne kopyalayıp çalıştırın.

Sub Test()
    Dim Say As Long
    Dim Bak As Long
    Dim Kopyala As Range
    Dim Yapistir As Range
    Say = Cells(Rows.Count, "A").End(3).Row
    For Bak = 4 To Say
        If Left(Cells(Bak, "A"), 1) = "E" And Left(Cells(Bak + 1, "A"), 1) = "Y" Then
            Set Kopyala = Range(Cells(Bak + 1, "A").Address & ":" & Cells(Bak + 1, Cells(Bak + 1, "A").End(xlToRight).Column).Address)
            Set Yapistir = Cells(Bak, Cells(Bak, "A").End(xlToRight).Column + 1)
            Kopyala.Copy Yapistir
            Kopyala.Delete shift:=xlUp
        ElseIf Left(Cells(Bak, "A"), 1) = "" Then
            Exit For
        End If
    Next
End Sub

 

[hamza2011]

Hocam, öncesinde belirtmeliydim aslında kusura bakmayın lütfen! Örnek dosyamın 2. sayfasında da örnek olarak belirttiğim gibi farklı sütunlarda bu şekilde boş hücreler olabiliyor. Bu haliyle çalıştırdığımda ise düzgün çalışmıyor.

 

[Muzaffer Ali]

O zaman şu kodları kullanın.

Sub Test()
    Dim Say As Long
    Dim SayKolon As Long
    Dim Bak As Long
    Dim Kopyala As Range
    Dim Yapistir As Range
    Say = Cells(Rows.Count, "A").End(3).Row
    For Bak = 4 To Say
        If Left(Cells(Bak, "A"), 1) = "E" And Left(Cells(Bak + 1, "A"), 1) = "Y" Then
            SayKolon = Cells(Bak, Columns.Count).End(1).Column
            Set Kopyala = Range(Cells(Bak + 1, "A").Address & ":" & Cells(Bak + 1, SayKolon).Address)
            Set Yapistir = Cells(Bak, SayKolon + 1)
            Kopyala.Copy Yapistir
            Kopyala.Delete shift:=xlUp
        ElseIf Left(Cells(Bak, "A"), 1) = "" Then
            Exit For
        End If
    Next
End Sub

 

[hamza2011]

Hocam çok teşekkür ederim. Çok güzel oldu. Zahmet verdim. İyi bakın kendinize.