Sayma ve sütunlara sıralama

[alperey333]

4 ayrı sütunda veri bulunmaktadır. 4'ünde de olanlar, 3'ünde, 2'sinde 1'inde olanları buldurup ayrı sütunlarda alt alta sıralatmak istiyorum.

 

[turist]

Ekli dosyayı inceleyiniz.

 

[apocalyt]

alternatif olsun..bir modüle kopyalayın..

Sub daylight()
Range("hz2:hz10000").ClearContents
Range("ar2:au10000").ClearContents
Range("d2:d" & [d1000].End(3).Row).Copy Range("hz2")
Range("o2" & [o1000].End(3).Row).Copy Range("hz" & [hz1000].End(3).Row + 1)
Range("z2:z" & [z1000].End(3).Row).Copy Range("hz" & [hz1000].End(3).Row + 1)
Range("ak2:ak" & [o1000].End(3).Row).Copy Range("hz" & [hz1000].End(3).Row + 1)
Range("hz2:hz1000").Sort key1:=Range("hz2"), order1:=xlAscending
y = 1
For x = 2 To [hz1000].End(3).Row
If Cells(x, "hz") = Cells(x + 1, "hz") Then
y = y + 1
Else
If y = 1 Then
Cells([au1000].End(3).Row + 1, "au") = Cells(x, "hz")
y = 1
GoTo atla
End If
If y = 2 Then
Cells([at1000].End(3).Row + 1, "at") = Cells(x, "hz")
y = 1
GoTo atla
End If
If y = 3 Then
Cells([as1000].End(3).Row + 1, "as") = Cells(x, "hz")
y = 1
GoTo atla
Else
Cells([ar1000].End(3).Row + 1, "ar") = Cells(x, "hz")
y = 1
GoTo atla
End If
End If
atla:
Next x
End Sub

 

[apocalyt]

gülücük olan yerde : o yazmaktadır..tabi arada boşluk yok..

 

[alperey333]

Teşekkürler sayın turist. Ve ayrıca size de teşekkür ederim sayın apocalyt.

 

[alperey333]

Maalesef dikkat etmediğim bir husus olmuş. Mevcut verileri el ile AN sütununda sıralamışsınız sayın turist. Oysa D-O-Z VE AK sütunlarındaki veriler formül sonuçları olarak gelmekte ve DEĞİŞKEN. Dolayısıyla her seferinde el ile sıralamak gerekeceğinden pek kullanışlı olmadı.

 

[turist]

Maalesef dikkat etmediğim bir husus olmuş. Mevcut verileri el ile AN sütununda sıralamışsınız sayın turist. Oysa D-O-Z VE AK sütunlarındaki veriler formül sonuçları olarak gelmekte ve DEĞİŞKEN. Dolayısıyla her seferinde el ile sıralamak gerekeceğinden pek kullanışlı olmadı.

Ekli dosyayı inceleyiniz.
Küçük bir Kaydet Makro eklenmiştir, istediğiniz şekilde sayfanız güncellenecektir.

 

[alperey333]

Teşekkürler. Ancak keşke fonksiyonlarla bir çözüm yolu olabilseydi.