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

meda58 · 29 Kasım 2022

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

veyselemre · 29 Kasım 2022

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

Haluk · 29 Kasım 2022

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.

.

meda58 · 30 Kasım 2022

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

hocam çok güzel çalışıyor fakat 1500 satır olduğundan dolayı çok yavaş bunu hızlandırmanın yolu yok mu

Haluk · 30 Kasım 2022

meda58' Alıntı:
hocam kusura bakmayın anlamadım örneklerseniz çok sevinirim

.

meda58 · 30 Kasım 2022

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.

.

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

veyselemre · 30 Kasım 2022

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

YUSUF44 · 30 Kasım 2022

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

Ömer üstadın çözümünde iş bitince ilave sütunu silebilir ya da gizleyebilirsiniz. En pratik ve hızlı yöntem budur.

meda58 · 30 Kasım 2022

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

hocam maalesef her şeyi denedim ama beklentilerimizi karşılamıyor diğeri çok iyi ama çok yavaş

meda58 · 30 Kasım 2022

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.

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ş

YUSUF44 · 30 Kasım 2022

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

YUSUF44 · 30 Kasım 2022

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"

YUSUF44 · 30 Kasım 2022

meda58' Alıntı:
hocam maalesef her şeyi denedim ama beklentilerimizi karşılamıyor diğeri çok iyi ama çok yavaş

Ben de 11. mesajda aynı yöntemi önerdim. Beklentinizi karşılamayan kısmı nedir?

Haluk · 30 Kasım 2022

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.

Ömer Üstad'ın çözümü hangisi ? Göremedim de....

.

Necdet · 30 Kasım 2022

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

meda58 · 1 Aralık 2022

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

meda58 · 1 Aralık 2022

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

hocam gayet güzel çalışıyor teşekkürler

YUSUF44 · 1 Aralık 2022

Haluk' Alıntı:
Ömer Üstad'ın çözümü hangisi ? Göremedim de....

.

Pardon üstadım. Bugünlerde dengesizliğim üzerimde. Kusura bakmayın.

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

meda58

veyselemre

Özel Üye

Haluk

Özel Üye

meda58

Haluk

Özel Üye

meda58

veyselemre

Özel Üye

YUSUF44

Destek Ekibi

meda58

meda58

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

Haluk

Özel Üye

Necdet

Moderatör

meda58

meda58

YUSUF44

Destek Ekibi