Belirsiz sütunlu bir aralıktaki verileri sıralama

[PColik]

Merhabalar linkteki görselde olduğu gibi bir listem var bu listede bulunan tüm isimleri başka bir sayfaya alfabetik sıraya göre yazdırıp yanlarına da dahili telefonlarını getirmenin bir yolu var mıdır? Teşekkürler

Not: Liste sürekli güncellenmektedir.

Ekran-Al-nt-s hosted at ImgBB

Image Ekran-Al-nt-s hosted in ImgBB

ibb.co

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kod ile olur.

Sub Aktar()
    Dim Sutun As Long, Say1 As Long, Say2 As Long
    Dim syf1 As Worksheet, syf2 As Worksheet
    Application.ScreenUpdating = False
    Set syf1 = ThisWorkbook.Worksheets("Sayfa1")
    Set syf2 = ThisWorkbook.Worksheets("Sayfa2")
    
    syf2.Range("A:B").Clear 'Önceki kayıtların Sayfa2 den silinmeden üzerine kaydedilmesini isterseniz bu satırı silin.
    
    syf2.Range("A1") = "İsim"
    syf2.Range("B1") = "Dahili No"
    
    For Sutun = 3 To syf1.Cells(1, Columns.Count).End(xlToLeft).Column Step 4
        Say1 = syf1.Cells(Rows.Count, Sutun).End(xlUp).Row
        Say2 = syf2.Cells(Rows.Count, "A").End(xlUp).Row + 1
        
        syf1.Range(syf1.Cells(2, Sutun).Address & ":" & syf1.Cells(Say1, Sutun).Address).Copy syf2.Cells(Say2, "A")
        syf1.Range(syf1.Cells(2, Sutun - 2).Address & ":" & syf1.Cells(Say1, Sutun - 2).Address).Copy syf2.Cells(Say2, "B")
    Next
    
    syf2.Sort.SortFields.Add2 Key:=Range("A2:A" & Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With syf2.Sort
        .SetRange Range("A:B")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        
        .Apply
        Application.ScreenUpdating = True
    End With
End Sub

 

[PColik]

Hocam çok teşekkür ediyorum çok makbule geçti. Başkaları faydalanmak isterse diye yazıyorum sıralama kısmına gelince hata vermişti "syf2.sort" tanımlamasını "ActiveWorkbook.Worksheets("Sayfa2").sort" olarak değiştirince düzeldi. Tekrar çok teşekkür ederim.