1 satır atlayıp satır seçmek

[Korhan Ayhan]

Aşağıdaki kodu kullanabilirsiniz.

Option Explicit

Sub Aktar()
    Dim Veri As Variant, Son As Long, X As Long, Say As Long, Sutun As Integer, Zaman As Double
   
    Zaman = Timer
   
    Son = Cells(Rows.Count, 1).End(3).Row
   
    Veri = Range("A1:A" & Son).Value
   
    Range("B:XFD").ClearContents
   
    ReDim Liste(1 To UBound(Veri), 1 To Columns.Count)
   
    For X = LBound(Veri) To UBound(Veri)
        If IsNumeric(Left(Veri(X, 1), 1)) Then
            Sutun = 2
            Say = Say + 1
            Liste(Say, 1) = Veri(X, 1)
        Else
            Liste(Say, Sutun) = Veri(X, 1)
            Sutun = Sutun + 1
        End If
    Next

    Range("B1").Resize(Say, Sutun) = Liste
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[Necdet]

Merhaba,
Geç kalmışım, Korhan bey kontrollü olarak kodları yazmış.


Hiç bir kontrol yapmadan her bilginin 3 satırdan oluştuğu varsayımına göre kod düzenlenmiştir.
Arada farklı olursa yanlış çalışır.
Yapı resimdeki gibi ise kodlar doğru çalışır.
Bir deneyin, aksaklık olursa kontrollü kodlar yazılır.

Veriler 1. satırdan başlıyorsa sorun yok, farklı satırdan başlıyorsa döngüdeki Başlanğıç sayısı 1 olan değeri değiştiriniz.

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. İlgili sayfanın da bir yedeğini alınız.

Sub Duzenle()

    Dim i   As Long
   
    Application.ScreenUpdating = False
   
    For i = 1 To Cells(Rows.Count, "A").End(3).Row - 2 Step 3
        Range("B" & i) = Range("A" & i).Offset(1, 0)
        Range("C" & i) = Range("A" & i).Offset(2, 0)
    Next i
   
    Range("B1:B" & i).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
    Application.ScreenUpdating = True

End Sub