alfabetik sıraya göre bir sayfadan bir sayfaya altalta aktarma

[Yesilyurtlu]

Üstadım;
Sayfa2 H sütununa yazılan isimleri aktar dedikçe
Sayfa3 C sütununa alt alta alfabetik sıraya göre aktarmak istiyorum.
Bu konuda yardımlarınıza ihtiyacım var.
Teşekkür Ederim.

 

[Necdet]

Merhaba,

Sorunuz tam açıklayıcı değil ama ben şöyle düşündüm :

Aktar butonuna her bastığınızda aktarılan değerler kırmızı olacak ve sayfa3 e aktarılacak.
Tekrar Aktar dediğinizde kırmızı olan değerler aktarılmayacak.

Sub Aktar()
 
    Dim i   As Long, _
        j   As Long, _
        Adt As Integer, _
        s2  As Worksheet, _
        s3  As Worksheet
    
    Set s2 = Sheets("Sayfa2")
    Set s3 = Sheets("Sayfa3")
    
    s2.Select
    
    j = s3.Cells(Rows.Count, "C").End(3).Row
    
    For i = 1 To Cells(Rows.Count, "H").End(3).Row
        If Not Range("H" & i).Font.Color = vbRed Then
            j = j + 1
            Adt = Adt + 1
            With Range("H" & i)
                .Copy s3.Cells(j, "C")
                .Font.Color = vbRed
            End With
        End If
    Next i
    If Adt > 0 Then
        s3.Range("C2:C" & j).Sort key1:=s3.[c1]
        MsgBox Adt & " Adet Bilgi Aktarılmıştır", vbInformation
    Else
        MsgBox "Aktarılacak Bilgi Bulunamadı", vbCritical
    End If
    
End Sub

 

[Emir Hüseyin Çoban]

Merhaba, Sy Necdet Yeşertener sizin kodlarınız kadar kapsamlı olmadı, ancak alternatif olabilir diye ekliyorum.

Sub aktar_sirala()
    Sheets("Sayfa2").Columns("H:H").Copy
    Sheets("Sayfa3").Columns("C:C").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Columns("C:C").Sort Key1:=Range("C1"), Order1:=xlAscending, DataOption1:=xlSortNormal
End Sub

 

[Yesilyurtlu]

Üstadım benim anlatamadığım konuyu çok güzel düzenlemiş ve sunmuşsunuz Teşekkür ederim.

Necdet Abi eğer fazla istekte bulunmuş olmazsam bir istirhamım daha olacak.

Şablon diye sayfam var ve gizli kalacak.
Commandbutton düğmesini clicklediğim zaman şablon sayfasının aynısından bir sayfa açacak
isim sayfasında ki adları yeni açılan şablon sayfasına B8 den itibaren sıralayacak.
Necdet Abi zahmet veriyorum ama Allah rızası için ekli dosyayı buna göre kodlayabilir misiniz?
Ben aşağıda ki kodu nette buldum ama zannedersem istediğim kod değil.





Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
On Error Resume Next
For i = 4 To Range("d65536").End(3).Row
Sheets("Sablon").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Sheets("Isim").Range("d" & i)
Sheets(Sheets.Count).Range("b8") = Sheets("Isim").Range("d" & i)
'Sheets(Sheets.Count).Range("C5") = Sheets("Isim").Range("B" & i)
'Sheets(Sheets.Count).Range("C6") = Sheets("Isim").Range("C" & i)
Next
Sheets("Şablon").Select
Application.ScreenUpdating = True
End Sub

 

[Yesilyurtlu]

Hüseyin Abim Mesajınızı ben mesaj yazarken göndermişsiniz göremedim.

Alternatif kodunuz için teşekkür ederim. Allah var etsin sizleri

 

[Necdet]

Merhaba,

Yeni oluşturulan sayfa adını siz kodda değiştirebilirsiniz. Ben "Sayfa" ile başlayan ve sayfa sayısını verdirdim. Örneğin yeni sayfa açıldıktan sonra 5 adet sayfa varsa yeni sayfanın adı "Sayfa5" yaptım.

Private Sub CommandButton1_Click()
    Dim i   As Long, _
        j   As Long, _
        Adt As Integer, _
        s2  As Worksheet, _
        s3  As Worksheet
    
    Sheets("Şablon").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "Sayfa" & Sheets.Count
    
    Set s2 = Sheets("İsim")
    Set s3 = Sheets("Sayfa" & Sheets.Count)
    
    s2.Select
    
    j = 7
    
    For i = 1 To Cells(Rows.Count, "H").End(3).Row
        If Not Range("H" & i).Font.Color = vbRed Then
            j = j + 1
            Adt = Adt + 1
            With Range("H" & i)
                s3.Cells(j, "B") = .Value
                .Font.Color = vbRed
            End With
        End If
    Next i
    If Adt > 0 Then
        s3.Range("B8:B" & j).Sort key1:=s3.[B7]
        MsgBox Adt & " Adet Bilgi Aktarılmıştır", vbInformation
    Else
        MsgBox "Aktarılacak Bilgi Bulunamadı", vbCritical
    End If
End Sub

 

[Yesilyurtlu]

Necdet Abi
Allah Ne muradın varsa versin abi.
Ellerine Sağlık. Teşekkür Ederim