Sayfa1'deki bilgileri Sayfa2'de alt alta sıralamak.

[S.Yiğit]

Merhaba,

Başlıkdan da belli olacağı gibi Sayfa1'de yan yana yazılmış bilgileri Sayfa2'de alt alta sıralamak. Eki incelersen daha iyi anlayabilirsiniz. Yardım edenlere şimdiden Teşekkürler. Makroyla bir butonla olursa çok güzel olur.

 

[Orion1]

Dsyanız ekte.

Sub aktar()
Sheets("Sheet1").Select
Application.ScreenUpdating = False
With Sheets("Sheet2")
    .Range("A:A").ClearContents
    For i = 1 To Cells(65536, "A").End(xlUp).Row
        For j = 1 To 4
            sat = sat + 1
            .Cells(sat, "A").Value = Cells(i, j).Value
        Next j
        sat = sat + 1
    Next i
End With
Application.ScreenUpdating = True
MsgBox "İşlem tamam"
End Sub

 

[S.Yiğit]

Sn Evren Gizlen hocam, Elinize sağlık. Tam istediğim gibi olmuş, Teşekkürler.

 

[Orion1]

Sn Evren Gizlen hocam, Elinize sağlık. Tam istediğim gibi olmuş, Teşekkürler.

Rica ederim.
İyi çalışmalar.

 

[S.Yiğit]

MErhaba,

Sevgili hocalarıma bişey sormak istiyorum. Butona bastığımda verileri sayfa2'ye aktardığında sayfa2'ye geçişde yapabilir mi?
Yani buton iki işlemi tek tıklama ile yapacak. İlk aktaracak Sonra sayfa2'ye geçecek.

 

[janveljan]

Başka yolla çözüm. Özel Yapıştır / İşlemi Tersine Çevir özelliği ile
Bu kodlar sadece en sona eklenenleri 2 nci sayfaya aktarır.

Sub sonuncuyuaktar()
    Application.ScreenUpdating = False
    n = [A65536].End(xlUp).Row
    Range("A" & n & ":D" & n).Select
    Selection.Copy
    Sheets("Sheet2").Select
    If [A65536].End(xlUp).Row = 1 Then n = 1 Else n = [A65536].End(xlUp).Row + 2
    Range("A" & n).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.ScreenUpdating = True
End Sub

Bu kodlar her defasında sayfa1 dekilerin tamamını sayfa2 ye aktarır.

Sub hepsiniaktar()
    Application.ScreenUpdating = False
    Sheets("Sheet2").Columns("A:A").ClearContents
    For i = 1 To [A65536].End(xlUp).Row
    Sheets("Sheet1").Select
    Range("A" & i & ":D" & i).Select
    Selection.Copy
    Sheets("Sheet2").Select
    If [A65536].End(xlUp).Row = 1 Then n = 1 Else n = [A65536].End(xlUp).Row + 2
    Range("A" & n).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[S.Yiğit]

Sn janveljan ilginize teşekkür ederim.

 

[onderkaptan]

merhaba
dosya x de a1 de yazan yazıyı dosya y de alt altta sıralamam mümkünmüdür. dosya x ın a1 de yazan yazılar hep degısıcek ama otomatık sekilde dosya y de alt alta sıralamış olucam..yardımcı olursanız cok sevınırım