satırı sütuna çevir

[emrebengul]

merhabalar arkadaşlar
sayfa 1 de Alt alta hazırlanmış olan harf ve sayıları sayfa 2 de karşılıklı olarak yazılmasını istiyorum. Excel dosyasında örnek olarak gösterdim. yardımcı olur musunuz?

 

[çıtır]

Deneyiniz.

Sub satırsutun()
Dim s1 As Worksheet: Dim s2 As Worksheet
Dim rng As Range
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
sat1 = 2: sat2 = 2
 son = s1.Cells(63555, "A").End(3).Row
For Each rng In s1.Range("A2:A" & son)
If IsNumeric(rng) = False Then
s2.Range("A" & sat1) = rng
sat1 = sat1 + 1
Else
s2.Range("B" & sat2) = rng
 sat2 = sat2 + 1
 End If
Next rng
 End Sub

 

[Korhan Ayhan]

Alternatif;

Hız olarak avantaj sağlayabilir.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long
    Dim Son As Long, Zaman As Double, Veri As Variant, Say As Long
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:A" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 2)
    
    S2.Range("A2:B" & S2.Rows.Count).ClearContents
    
    For X = LBound(Veri) To UBound(Veri) Step 2
        Say = Say + 1
        Liste(Say, 1) = Veri(X, 1)
        Liste(Say, 2) = Veri(X + 1, 1)
    Next

    S2.Range("A2").Resize(Say, 2) = Liste

    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub