• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

+ - değer gözetmeden sayı sıralama

M

meda58

Katılım
24 Eylül 2010
Mesajlar
168
Excel Vers. ve Dili
2010 tr
arkadaşlar elimde büyük bir tablo var D sütununda Sütun4 deki gibi - ve + değerlere sahip çok sayıda sayı var bunları normal şartlarda sıralayınca Sütun4 gibi oluyor bunu

Sütun7 gibi sayıların değer gözetmeden yalnızca küçükten büyüğe sıralamak mümkün olur mu

bütün işlem Sütun4 üzerinde olacak Sütun7 örnek olarak verilmiştir






Sütun1

Sütun2

Sütun3

Sütun4

Sütun5

Sütun6

Sütun7







-1200





-10







-150





20







-50





30







-10





-50







20





70







30





90







70





-150







90





450







450





-1200
 
Kod: 
Sub test()
    Dim i, son
    son = Cells(Rows.Count, 4).End(3).Row
    For i = 2 To son
        If Cells(i, 4).Value < 0 Then
            Cells(i, 4).Font.Bold = True
            Cells(i, 4).Value = Abs(Cells(i, 4).Value)
        End If
    Next i
    Range("A1:F" & son).Sort Range("D1"), xlAscending, , , , , , xlYes
    For i = 2 To son
        If Cells(i, 4).Font.Bold = True Then
            Cells(i, 4).Value = -1 * (Cells(i, 4).Value)
            Cells(i, 4).Font.Bold = False
        End If
    Next i
End Sub
 
Son düzenleme:
Excel'in yerleşik sıarlama fonksiyonuyla yapmak için; hemen yanındaki sütunda verilerin mutlak değerleri (İng. versiyonda ABS, Türkçe versiyonda MUTLAK) hesaplanır, bu 2 sütun seçildikten sonra mutlak değerlerin hesaplandığı sütuna göre sıralama yaptırılır.

.
 
veyselemre' Alıntı:
Kod: 
Sub test()
    Dim i, son
    son = Cells(Rows.Count, 4).End(3).Row
    For i = 2 To son
        If Cells(i, 4).Value < 0 Then
            Cells(i, 4).Font.Bold = True
            Cells(i, 4).Value = Abs(Cells(i, 4).Value)
        End If
    Next i
    Range("A1:F" & son).Sort Range("D1"), xlAscending, , , , , , xlYes
    For i = 2 To son
        If Cells(i, 4).Font.Bold = True Then
            Cells(i, 4).Value = -1 * (Cells(i, 4).Value)
            Cells(i, 4).Font.Bold = False
        End If
    Next i
End Sub
Genişletmek için tıkla ...

hocam çok güzel çalışıyor fakat 1500 satır olduğundan dolayı çok yavaş bunu hızlandırmanın yolu yok mu
 
Haluk' Alıntı:
Excel'in yerleşik sıarlama fonksiyonuyla yapmak için; hemen yanındaki sütunda verilerin mutlak değerleri (İng. versiyonda ABS, Türkçe versiyonda MUTLAK) hesaplanır, bu 2 sütun seçildikten sonra mutlak değerlerin hesaplandığı sütuna göre sıralama yaptırılır.

.
Genişletmek için tıkla ...


hocam anlatım ve çözdüm öncelikle teşekkürler yalnız aynı sütunda işaretler kaybolmadan nasıl bir çözüm üretilebilir
 
Kod: 
Sub test()

    Dim strCon$, strSql$, rs As Object
 
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & _
             "';Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"

    Set rs = CreateObject("Adodb.RecordSet")

    strSql = " SELECT * FROM [Sheet1$A:F] WHERE [Sütun1] IS NOT NULL ORDER BY ABS([Sütun4])"
    rs.Open strSql, strCon

    Range("A2").CopyFromRecordset rs

End Sub
 
meda58' Alıntı:
hocam anlatım ve çözdüm öncelikle teşekkürler yalnız aynı sütunda işaretler kaybolmadan nasıl bir çözüm üretilebilir
Genişletmek için tıkla ...
Ömer üstadın çözümünde iş bitince ilave sütunu silebilir ya da gizleyebilirsiniz. En pratik ve hızlı yöntem budur.
 
veyselemre' Alıntı:
Kod: 
Sub test()

    Dim strCon$, strSql$, rs As Object

    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & _
             "';Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"

    Set rs = CreateObject("Adodb.RecordSet")

    strSql = " SELECT * FROM [Sheet1$A:F] WHERE [Sütun1] IS NOT NULL ORDER BY ABS([Sütun4])"
    rs.Open strSql, strCon

    Range("A2").CopyFromRecordset rs

End Sub
Genişletmek için tıkla ...



hocam maalesef her şeyi denedim ama beklentilerimizi karşılamıyor diğeri çok iyi ama çok yavaş
 
YUSUF44' Alıntı:
Ömer üstadın çözümünde iş bitince ilave sütunu silebilir ya da gizleyebilirsiniz. En pratik ve hızlı yöntem budur.
Genişletmek için tıkla ...

hocam bende benzer bir yöntem kullanıyorum daha pratik ve kolay bir yöntem arayışındayım veysel emre beyin 1. verdiği makro güzel çalışıyor ama çok yavaş
 
Aşağıdaki gibi bir kod dener misiniz?

(Koddaki sayfa ismini -Sayfa1- ve sütun ismini -d- kendi dosyanıza göre uyarlayın)

PHP: 
Sub sirala()
Set s1 = Sheets("Sayfa1")

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select * from [Sayfa1$] where d is not null order by abs(d) asc"
Set rs = con.Execute(sorgu)

s1.[A2].CopyFromRecordset rs

End Sub
 
Kendi dosyanıza göre düzeltmeniz gerekenler aşağıdaki koyu olan yerlerdir:

Set s1 = Sheets("Sayfa1")

sorgu = "select * from [Sayfa1$] where d is not null order by abs(d) asc"
 
meda58' Alıntı:
hocam maalesef her şeyi denedim ama beklentilerimizi karşılamıyor diğeri çok iyi ama çok yavaş
Genişletmek için tıkla ...
Ben de 11. mesajda aynı yöntemi önerdim. Beklentinizi karşılamayan kısmı nedir?
 
Alternatif olsun, şansımı deneyim :)

Kod: 
Sub SortArray()
'https://www.mrexcel.com/board/threads/vba-to-sort-an-array-of-numbers.690718/

Dim MyArray As Variant, i As Long
i = Cells(Rows.Count, "E").End(3).Row
MyArray = Range("E1:E" & i).Value
MyArray = BubbleSrt(MyArray, 1) '0 Büyükten Küçüğe, 1 Küçükten Büyüğe Sıralar
Range("F1").Resize(UBound(MyArray, 1), 1) = MyArray

End Sub

Public Function BubbleSrt(ArrayIn, Ascending As Boolean)
Dim SrtTemp As Variant
Dim i As Long
Dim j As Long
If Ascending = True Then
  For i = LBound(ArrayIn) To UBound(ArrayIn)
    For j = i + 1 To UBound(ArrayIn)
      If Abs(ArrayIn(i, 1)) > Abs(ArrayIn(j, 1)) Then
        SrtTemp = ArrayIn(j, 1)
        ArrayIn(j, 1) = ArrayIn(i, 1)
        ArrayIn(i, 1) = SrtTemp
      End If
    Next j
  Next i
Else
  For i = LBound(ArrayIn) To UBound(ArrayIn)
    For j = i + 1 To UBound(ArrayIn)
      If Abs(ArrayIn(i, 1)) < Abs(ArrayIn(j, 1)) Then
        SrtTemp = ArrayIn(j, 1)
        ArrayIn(j, 1) = ArrayIn(i, 1)
        ArrayIn(i, 1) = SrtTemp
      End If
    Next j
   Next i
End If
BubbleSrt = ArrayIn
End Function
 
YUSUF44' Alıntı:
Aşağıdaki gibi bir kod dener misiniz?

(Koddaki sayfa ismini -Sayfa1- ve sütun ismini -d- kendi dosyanıza göre uyarlayın)

PHP: 
Sub sirala()
Set s1 = Sheets("Sayfa1")

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select * from [Sayfa1$] where d is not null order by abs(d) asc"
Set rs = con.Execute(sorgu)

s1.[A2].CopyFromRecordset rs

End Sub

hocam teşekkürler gayet güzel çalışıyor
Genişletmek için tıkla ...
 
Necdet' Alıntı:
Alternatif olsun, şansımı deneyim :)

Kod: 
Sub SortArray()
'https://www.mrexcel.com/board/threads/vba-to-sort-an-array-of-numbers.690718/

Dim MyArray As Variant, i As Long
i = Cells(Rows.Count, "E").End(3).Row
MyArray = Range("E1:E" & i).Value
MyArray = BubbleSrt(MyArray, 1) '0 Büyükten Küçüğe, 1 Küçükten Büyüğe Sıralar
Range("F1").Resize(UBound(MyArray, 1), 1) = MyArray

End Sub

Public Function BubbleSrt(ArrayIn, Ascending As Boolean)
Dim SrtTemp As Variant
Dim i As Long
Dim j As Long
If Ascending = True Then
  For i = LBound(ArrayIn) To UBound(ArrayIn)
    For j = i + 1 To UBound(ArrayIn)
      If Abs(ArrayIn(i, 1)) > Abs(ArrayIn(j, 1)) Then
        SrtTemp = ArrayIn(j, 1)
        ArrayIn(j, 1) = ArrayIn(i, 1)
        ArrayIn(i, 1) = SrtTemp
      End If
    Next j
  Next i
Else
  For i = LBound(ArrayIn) To UBound(ArrayIn)
    For j = i + 1 To UBound(ArrayIn)
      If Abs(ArrayIn(i, 1)) < Abs(ArrayIn(j, 1)) Then
        SrtTemp = ArrayIn(j, 1)
        ArrayIn(j, 1) = ArrayIn(i, 1)
        ArrayIn(i, 1) = SrtTemp
      End If
    Next j
   Next i
End If
BubbleSrt = ArrayIn
End Function
Genişletmek için tıkla ...


hocam gayet güzel çalışıyor teşekkürler
 
Haluk' Alıntı:
Ömer Üstad'ın çözümü hangisi ? Göremedim de....

.
Genişletmek için tıkla ...
Pardon üstadım. Bugünlerde dengesizliğim üzerimde. Kusura bakmayın.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst