Önbelleğe alınan veri setini önbellekte sıralama yapma

dogan081 · 11 Temmuz 2019

Değerli hocalarım, aşağıda yazdığım kodlama ile Sayfa1 A sütununda var olan tüm veriyi ön belleğe alıyorum. Bu veri yine önbellekte olacak şekilde artan yada azalan sıralama yapmam mümkün mü? Sıralamayı hücrelerde yapıp sonra önbelleğe almam mümkün ancak, istediğim sonuç için uygun bir yöntem olmuyor. Değerli katkılarınız için şimdiden teşekkür ederim. Hayırlı geceler.

son = Sayfa1.Cells(Rows.Count, "A").End(3).Row

ReDim x(son, 1) As Double

For i = 1 To son
x(son, 1) = Sayfa1.Range("A1:A" & son)
Next

mancubus · 11 Temmuz 2019

Type Mismatch (13) hatası alırsınız bu satırlar ile.

mancubus · 11 Temmuz 2019

Kod:

Sub TestSortArrayMacro()

    Dim i As Long, son As Long
    Dim dizi
 
    With Sayfa1
        son = .Cells(.Rows.Count, 1).End(xlUp).Row
        ReDim dizi(1 To son)
     
        For i = 1 To son
            dizi(i) = .Cells(i, 1).Value
        Next i
    End With
 
    dizi = SortArrayAtoZ(dizi)
    MsgBox Join(dizi, vbLf)

    dizi = SortArrayZtoA(dizi)
    MsgBox Join(dizi, vbLf)

End Sub


Function SortArrayAtoZ(myArray As Variant)
'https://exceloffthegrid.com/sorting-an-array-alphabetically-with-vba/
    Dim i As Long
    Dim j As Long
    Dim Temp
 
    'Sort the Array A-Z
    For i = LBound(myArray) To UBound(myArray) - 1
        For j = i + 1 To UBound(myArray)
            If UCase(myArray(i)) > UCase(myArray(j)) Then
                Temp = myArray(j)
                myArray(j) = myArray(i)
                myArray(i) = Temp
            End If
        Next j
    Next i
 
    SortArrayAtoZ = myArray

End Function

Function SortArrayZtoA(myArray As Variant)
'https://exceloffthegrid.com/sorting-an-array-alphabetically-with-vba/
    Dim i As Long
    Dim j As Long
    Dim Temp
 
    'Sort the Array Z-A
    For i = LBound(myArray) To UBound(myArray) - 1
        For j = i + 1 To UBound(myArray)
            If UCase(myArray(i)) < UCase(myArray(j)) Then
                Temp = myArray(j)
                myArray(j) = myArray(i)
                myArray(i) = Temp
            End If
        Next j
    Next i
 
    SortArrayZtoA = myArray

End Function

dogan081 · 11 Temmuz 2019

mancubus' Alıntı:

Kod:

Sub TestSortArrayMacro()

    Dim i As Long, son As Long
    Dim dizi

    With Sayfa1
        son = .Cells(.Rows.Count, 1).End(xlUp).Row
        ReDim dizi(1 To son)
    
        For i = 1 To son
            dizi(i) = .Cells(i, 1).Value
        Next i
    End With

    dizi = SortArrayAtoZ(dizi)
    MsgBox Join(dizi, vbLf)

    dizi = SortArrayZtoA(dizi)
    MsgBox Join(dizi, vbLf)

End Sub


Function SortArrayAtoZ(myArray As Variant)
'https://exceloffthegrid.com/sorting-an-array-alphabetically-with-vba/
    Dim i As Long
    Dim j As Long
    Dim Temp

    'Sort the Array A-Z
    For i = LBound(myArray) To UBound(myArray) - 1
        For j = i + 1 To UBound(myArray)
            If UCase(myArray(i)) > UCase(myArray(j)) Then
                Temp = myArray(j)
                myArray(j) = myArray(i)
                myArray(i) = Temp
            End If
        Next j
    Next i

    SortArrayAtoZ = myArray

End Function

Function SortArrayZtoA(myArray As Variant)
'https://exceloffthegrid.com/sorting-an-array-alphabetically-with-vba/
    Dim i As Long
    Dim j As Long
    Dim Temp

    'Sort the Array Z-A
    For i = LBound(myArray) To UBound(myArray) - 1
        For j = i + 1 To UBound(myArray)
            If UCase(myArray(i)) < UCase(myArray(j)) Then
                Temp = myArray(j)
                myArray(j) = myArray(i)
                myArray(i) = Temp
            End If
        Next j
    Next i

    SortArrayZtoA = myArray

End Function

mancubus emeğine sağlık, çok teşekkür ederim.

Haluk · 11 Temmuz 2019

Alternatif:

Verilerin artan veya azalana göre sıralanması, bunların direkt olarak gösterilmesi, sıralanan verilerin bir diziye aktarılması, diziden okutulması ve dizinin sayfaya aktarilmasına ilişkin çeşitli alternatif işlemlerin ele alindiği ADO ile yapilmiş bir örnek;

Kod:

Sub Test()
    'Haluk - 11/07/2019
    'sa4truss@gmail.com
    Dim myArr(), i As Integer
    Dim adoCN As Object, RS As Object
    
    Const adOpenKeyset = 1
    
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
    
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Extended Properties") = "Excel 8.0; HDR= Yes;"
    adoCN.ConnectionString = ThisWorkbook.FullName
    adoCN.Open
    
'    Buyukten kucuge dogru siralama
'    strSQL = "Select [Veriler] from [Sheet1$] order by [Veriler] desc"
    
'    Kucukten buyuge dogru siralama
    strSQL = "Select [Veriler] from [Sheet1$] order by [Veriler] asc"

    RS.CursorType = adOpenKeyset
    
    RS.Open strSQL, adoCN
    RS.Movelast
    RS.Movefirst
    
'    RecordSet verilerini myArr dizisine almak icin
    myArr = Application.Transpose(RS.Getrows(RS.RecordCount))
    
'    Siralanan RecordSet verilerini gostermek icin
    RS.Movefirst
    For i = 1 To RS.RecordCount
        MsgBox RS(0)
        RS.Movenext
    Next
    
'    Siralanarak myArr dizisine aktarilan verileri gostermek icin
    For i = LBound(myArr) To UBound(myArr)
        MsgBox myArr(i, 1)
    Next
    
'    Verileri myArr dizisinden okuyarak sayfada B sutununda listelemek icin
    Range("B2").Resize(UBound(myArr)) = myArr
    
'    Temizlik
    Erase myArr
    Set RS = Nothing
    Set adoCN = Nothing
End Sub

.

Haluk · 11 Temmuz 2019

WordBasic'in "SortArray" fonksiyonunu kullanarak;

Kod:

Sub Test2()
    'Haluk - 11/07/2019
    'sa4truss@gmail.com
    Dim NoA As Integer, i As Integer, myArr()
   
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    ReDim myArr(1 To (NoA - 1))
   
    For i = 2 To (NoA - 1)
        myArr(i) = Range("A" & i)
    Next

    Set MyWd = CreateObject("Word.Application")
    MyWd.WordBasic.SortArray myArr(), 1
   
    For i = 1 To UBound(myArr)
        Liste = Liste & i & ". değer = " & myArr(i) & vbCrLf
    Next
   
    MsgBox "Yüksekten azalana doğru sıralama:" & vbCrLf & vbCrLf & Liste & vbCrLf & vbCrLf & "En buyuk deger = " & myArr(1)
   
    MyWd.Quit
    Set MyWd = Nothing
    Erase myArr
End Sub

.

Haluk · 11 Temmuz 2019

"System.Collections" kullanarak artan veya azalan sıralama yapılması;

Kod:

Sub Test3()
    'Haluk - 11/07/2019
    'sa4truss@gmail.com
    Dim NoA As Integer, myArr(), myList As Object, i As Integer
    
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    myArr = Range("A2:A" & NoA)

    Set myList = CreateObject("System.Collections.ArrayList")
    
    For i = 1 To UBound(myArr)
       If Not myList.Contains(myArr(i, 1)) Then myList.Add myArr(i, 1)
    Next
    
'    Kucukten buyuge dogru siralama
    myList.Sort
    
'    Buyukten kucuge dogru siralama yapmak icin asagidaki satiri aktif hale getirin
'    myList.Reverse
    
    For i = 0 To myList.Count - 1
        MsgBox myList(i)
    Next
End Sub

mancubus · 11 Temmuz 2019

dogan081' Alıntı:
mancubus emeğine sağlık, çok teşekkür ederim.

rica ederim.
kolay gelsin.

dogan081 · 11 Temmuz 2019

Haluk' Alıntı:

"System.Collections" kullanarak artan veya azalan sıralama yapılması;

Kod:

Sub Test3()
    'Haluk - 11/07/2019
    'sa4truss@gmail.com
    Dim NoA As Integer, myArr(), myList As Object, i As Integer
   
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    myArr = Range("A2:A" & NoA)

    Set myList = CreateObject("System.Collections.ArrayList")
   
    For i = 1 To UBound(myArr)
       If Not myList.Contains(myArr(i, 1)) Then myList.Add myArr(i, 1)
    Next
   
'    Kucukten buyuge dogru siralama
    myList.Sort
   
'    Buyukten kucuge dogru siralama yapmak icin asagidaki satiri aktif hale getirin
'    myList.Reverse
   
    For i = 0 To myList.Count - 1
        MsgBox myList(i)
    Next
End Sub

Haluk bey elinize sağlık güzel oldu
Bende sonuna ufak bir katkı yaptım. Sizin yaptığınız bir aralıktaki benzersiz değerleri artan yada azalan şekilde sıralamayı güzel yaptı. Anlaşırlı olsun diye önbellekteki değeri hücreye yazmaya ve aralıktaki benzersiz toplam değeri hücreye aktarmak için ufak bir dokunuş yaptım.

Sub Test3()
'Haluk - 11/07/2019
'sa4truss@gmail.com
Dim NoA As Integer, myArr(), myList As Object, i As Integer

NoA = Range("A" & Rows.Count).End(xlUp).Row
myArr = Range("A2:A" & NoA)

Set myList = CreateObject("System.Collections.ArrayList")

For i = 1 To UBound(myArr)
If Not myList.Contains(myArr(i, 1)) Then myList.Add myArr(i, 1)
Next

' Kucukten buyuge dogru siralama
myList.Sort

' Buyukten kucuge dogru siralama yapmak icin asagidaki satiri aktif hale getirin
' myList.Reverse

' YENİ EKLENEN BÖLÜM
For i = 0 To myList.Count - 1
Sayfa1.Cells(i + 1, 2) = myList(i) 'mylisti b sütununa yazdır
Sayfa1.Range("C1") = myList.Count 'listedeki benzersizlerin toplam sayısı
Next

' MsgBox myList(i)

Exit Sub
End Sub

dogan081 · 11 Temmuz 2019

Haluk bey eğer değer sadece rakam değilde metin ile karışık olursa bir hata söz konusu.
Değerlerin tamamı metin yada rakam mı olması gerekiyor.
Örneğin 3 satırda rakam sonraki beş satırda metin olursa "myList.Sort " sıralama kodunda hata veriyor.

' YENİ EKLENEN BÖLÜM
For i = 0 To myList.Count - 1
Sayfa1.Cells(i + 1, 2) = myList(i) 'mylisti b sütununa yazdır
Next

Sayfa1.Range("C1") = myList.Count 'listedeki benzersizlerin toplam sayısı *** Yalnışlıkla döngü içine koymuşum, dışarıda olması lazımdı***

Haluk · 11 Temmuz 2019

Mantıklı olan; listenin sadece "metin" veya "nümerik" olmasıdır...... Ondan sonra sıralama için uygun bir yöntem seçilir.

.

dogan081 · 11 Temmuz 2019

Haluk' Alıntı:
Mantıklı olan; listenin sadece "metin" veya "nümerik" olmasıdır...... Ondan sonra sıralama için uygun bir yöntem seçilir.

.

"System.Collections" kodlamasını kullanmak istediğimde herhangi bir sınırlama söz konusu mu.
Excelin mevcutta bulunan bütün sürümlerinde sorunsuz çalışır mı? Bu soruda nereden çıktı demeyin lütfen.

Haluk · 11 Temmuz 2019

.Net Framework 3.5 yüklü olması gerekir.....

.

dogan081 · 11 Temmuz 2019

Haluk' Alıntı:
.Net Framework 3.5 yüklü olması gerekir.....

.

Teşekkür ederim emeğinize sağlık

Zeki Gürsoy · 11 Temmuz 2019

Framework sınıfları ile başka işler yapabilmek için buraya bakabilirsiniz.

Haluk · 11 Temmuz 2019

Haluk' Alıntı:
.Net Framework 3.5 yüklü olması gerekir.....

Normal şartlarda Windows Vista, Windows XP sistemlerinden itibaren kullanılır.....

.

Haluk · 11 Temmuz 2019

Bilgisayarda .NET Framework 3.5 yüklü olup olmadığını anlamak için;

Kod:

Sub Test4()
    'Haluk - 11/07/2019
    'sa4truss@gmail.com
    MsgBox isDotNetFramework35_Installed
End Sub
'
Function isDotNetFramework35_Installed() As Boolean
    'Haluk - 11/07/2019
    'sa4truss@gmail.com
    Dim objShell As Object, myKey As String
    
    myKey = "HKLM\Software\Microsoft\NET Framework Setup\NDP\v3.5\Version"
    
    Set objShell = CreateObject("WScript.Shell")
    
    On Error Resume Next
    strKeyValue = objShell.RegRead(myKey)
    If Err Then
        isDotNetFramework35_Installed = False
    Else
        isDotNetFramework35_Installed = True
    End If
    Set objShell = Nothing
End Function

.

.

dogan081 · 11 Temmuz 2019

Haluk' Alıntı:

Bilgisayarda .NET Framework 3.5 yüklü olup olmadığını anlamak için;

Kod:

Sub Test4()
    'Haluk - 11/07/2019
    'sa4truss@gmail.com
    MsgBox isDotNetFramework35_Installed
End Sub
'
Function isDotNetFramework35_Installed() As Boolean
    'Haluk - 11/07/2019
    'sa4truss@gmail.com
    Dim objShell As Object, myKey As String
   
    myKey = "HKLM\Software\Microsoft\NET Framework Setup\NDP\v3.5\Version"
   
    Set objShell = CreateObject("WScript.Shell")
   
    On Error Resume Next
    strKeyValue = objShell.RegRead(myKey)
    If Err Then
        isDotNetFramework35_Installed = False
    Else
        isDotNetFramework35_Installed = True
    End If
    Set objShell = Nothing
End Function

.

.

Haluk bey, Emeğinize sağlık değerleri katkılar verdiniz

Önbelleğe alınan veri setini önbellekte sıralama yapma

dogan081

mancubus

Destek Ekibi

mancubus

Destek Ekibi

dogan081

Haluk

𐱅𐰇𐰼𐰚

Haluk

𐱅𐰇𐰼𐰚

Haluk

𐱅𐰇𐰼𐰚

mancubus

Destek Ekibi

dogan081

dogan081

Haluk

𐱅𐰇𐰼𐰚

dogan081

Haluk

𐱅𐰇𐰼𐰚

dogan081

Zeki Gürsoy

Uzman

Haluk

𐱅𐰇𐰼𐰚

Haluk

𐱅𐰇𐰼𐰚

dogan081