Aktar Makrosuna "Alfabetik" Ekleme

[sirkülasyon]

Sub HücreAktar()
    Dim son As Long
    With Sheets("ARŞİV")
    son = .Cells(Rows.Count, "B").End(xlUp).Row + 1
        .Range("A" & son) = son - 1
        .Range("B" & son) = Range("B5")
        .Range("C" & son) = Range("C5")
        .Range("D" & son) = Range("D5")
        .Range("E" & son) = Range("E5")
        .Range("F" & son) = Range("F5")
        .Range("G" & son) = Range("G5")
        .Range("H" & son) = Range("H5")
        .Range("I" & son) = Range("I5")
        .Range("J" & son) = Range("J5")
        .Range("K" & son) = Range("K5")
        .Range("L" & son) = Range("L5")
        .Range("M" & son) = Range("M5")
        .Range("N" & son) = Range("N5")
        .Range("O" & son) = Range("O5")
        .Range("P" & son) = Range("P5")
        .Range("Q" & son) = Range("Q5")
        .Range("R" & son) = Range("R5")
        .Range("S" & son) = Range("S5")
        .Range("T" & son) = Range("T5")
    End With
End Sub

"Yukarıda yer alan kod Ömer Uzmanıma aittir"

Yukarıda yer alan kod ile aktarma yapıyorum. Ancak B5 ve E5 hücrelerine göre Alfabetik olarak aktarmasını istiyorum.

Yardımcı olabilir misiniz?

 

[YUSUF44]

"B5 ve E5 hücrelerine göre alfabetik aktarmak" ne demek?

 

[sirkülasyon]

Yusuf Hocam
B sütununda Ad soyad yazılı E sütununda da 01.01.2017 - 31.01.2017 şeklinde tarih yazılı
Ad soyad aynı olanları alt alta aktarırken de E sütununda ki tarihe göre bakacak.
E sütununda ki tarih Ocak ayı içerisinde ise ilk sıraya Şubat ise ikinci sıraya gibi.

 

[Korhan Ayhan]

Örnek dosyanızı ekleyiniz.

 

[sirkülasyon]

Üstadım
Dosya eklendi.

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz.

ARŞİV sayfasında "U" sütunu yardımcı sütun olarak kullanılmıştır.

Sub HücreAktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, Ay As Byte
 
    Set S1 = Sheets("Bordro")
    Set S2 = Sheets("Arşiv")
 
    Ay = Month(Split(S1.Range("H5"), "        ")(0))
 
    With S2
    Son = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
        .Range("A" & Son) = Son - 2
        .Range("B" & Son) = S1.Range("B5")
        .Range("C" & Son) = S1.Range("C5")
        .Range("D" & Son) = S1.Range("D5")
        .Range("E" & Son) = S1.Range("E5")
        .Range("F" & Son) = S1.Range("F5")
        .Range("G" & Son) = S1.Range("G5")
        .Range("H" & Son) = S1.Range("H5")
        .Range("I" & Son) = S1.Range("I5")
        .Range("J" & Son) = S1.Range("J5")
        .Range("K" & Son) = S1.Range("K5")
        .Range("L" & Son) = S1.Range("L5")
        .Range("M" & Son) = S1.Range("M5")
        .Range("N" & Son) = S1.Range("N5")
        .Range("O" & Son) = S1.Range("O5")
        .Range("P" & Son) = S1.Range("P5")
        .Range("Q" & Son) = S1.Range("Q5")
        .Range("R" & Son) = S1.Range("R5")
        .Range("S" & Son) = S1.Range("S5")
        .Range("T" & Son) = S1.Range("T5")
        .Range("U" & Son) = Ay
        .Range("B3:U" & Son).Sort .Range("U3"), xlAscending
    End With
End Sub

 

[sirkülasyon]

Korhan abi
U sütununda 1 yazıyor. Ancak B ve E sütununda bir değişiklik olmadı. Ya da ben uygulayamadım

 

[Korhan Ayhan]

U3 hücresinden itibaren aşağıdaki formülü bir seferlik uygulayın.

=AY(KIRP(SOLDAN(H3;MBUL("        ";H3;1))))

Sonra bu sütunu formüllerden arındırın. Yani değere çevirin.

Son olarak üstteki makroyu kullanarak bir adet kayıt işlemi yapın. Bu şekilde eski kayıtlarınızda sıralama işlemi gerçekleşecektir.

 

[sirkülasyon]

Korhan Abi;
Hayırlı Sabahlar. Abim benim aktarma esnasında sıralamayı ödeme dönemine göre diziyor.
U Sayfasında aynı olan ödeme günlerine de aynı numarayı veriyor. Ancak B sütununda bulunan ad ve soyad kriterine göre bir alfabetik dizim yok.

Önce ada göre aktarsa sonra kendi aralarında tarihe göre dizse olur mu?
Kızacaksın biliyorum abi ama vallahi bu şekilde olursa daha çok işime yarayacak.

Sağlıcakla kal abi

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub HücreAktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long
 
    Set S1 = Sheets("Bordro")
    Set S2 = Sheets("Arşiv")
 
    With S2
         Son = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
        .Range("A" & Son) = Son - 2
        .Range("B" & Son) = S1.Range("B5")
        .Range("C" & Son) = S1.Range("C5")
        .Range("D" & Son) = S1.Range("D5")
        .Range("E" & Son) = S1.Range("E5")
        .Range("F" & Son) = S1.Range("F5")
        .Range("G" & Son) = S1.Range("G5")
        .Range("H" & Son) = S1.Range("H5")
        .Range("I" & Son) = S1.Range("I5")
        .Range("J" & Son) = S1.Range("J5")
        .Range("K" & Son) = S1.Range("K5")
        .Range("L" & Son) = S1.Range("L5")
        .Range("M" & Son) = S1.Range("M5")
        .Range("N" & Son) = S1.Range("N5")
        .Range("O" & Son) = S1.Range("O5")
        .Range("P" & Son) = S1.Range("P5")
        .Range("Q" & Son) = S1.Range("Q5")
        .Range("R" & Son) = S1.Range("R5")
        .Range("S" & Son) = S1.Range("S5")
        .Range("T" & Son) = S1.Range("T5")
        .Range("U3:U" & Son).Formula = "=MONTH(TRIM(MID(H3,1,SEARCH(""        "",H3,1)-1)))"
        .Range("U3:U" & Son).Value = .Range("U3:U" & Son).Value
        .Range("B3:U" & Son).Sort .Range("U3"), xlAscending, .Range("B3"), , xlAscending
    End With
End Sub

 

[sirkülasyon]

Korhan abi
Bu konu ile ilgili bir kez daha ve utanarak bir istirhamım olacak.
Ekli sayfada Talep edilen sekmesinde ki şekilde aktarma yapabilir miyiz.

Korhan abi gerçekten seni ziyadesi ile rahatsız ettim. Hakkını helal et. Hata bende. Çok çok özür dilerim abi

Sağlıcakla.

 

[Korhan Ayhan]

Kod içindeki aşağıdaki satırı bulun. Kırmızı bölümleri yer değiştirin.

.Range("B3:U" & Son).Sort .Range("[COLOR="red"]U[/COLOR]3"), xlAscending, .Range("[COLOR="Red"]B[/COLOR]3"), , xlAscending

 

[sirkülasyon]

Korhan abi
İşlem Tamam.
Sabır gösterip yardımcı olduğunuz için teşekkür ederim. Hakkını helal et abim benim. Sağ olasın
Sağlıcakla kal inşallah.

 

[Korhan Ayhan]

Rica ederim. Hakkım varsa helâl olsun.

 

[assenucler]

Sayın sirkülasyon,


Dosyanın son haline ekler misiniz?

Emek ve katkıda bulunan üyemize ve üstadımıza teşekkürler.

Sevgi ve saygılar.

 

[sirkülasyon]

Sayın assenucler
Forumda hem dosya hem de Korhan abimin kodları mevcuttur. Başım üstüne tekrar ekleyeyim.