كود فرز وترتيب بثلاث معايير

Option Explicit



Sub Sort_Data_WithADO()



    Dim rngInput As Range, rngOutput As Range, varSortedData As Variant

    Dim strWbName As String, strConnection As String, strRangeReference As String, strSql As String

    Dim objConnection As ADODB.Connection, objRecordSet As ADODB.Recordset



    ' set input range - includes header

    Set rngInput = ThisWorkbook.Worksheets("Sheet1").Range("A1:p26")

    ' set output range - just the first cell

    Set rngOutput = ThisWorkbook.Worksheets("Sheet2").Range("a1")

    ' copy the headers over

    rngOutput.Resize(1, 16).Value = rngInput.Rows(1).Value

    ' connection string for ACE OLEDB provider

    strWbName = ThisWorkbook.FullName

    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _

        "Data Source=" & strWbName & ";" & _

        "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"

    ' make the connection to current workbook (better saved the workbook first)

    Set objConnection = New ADODB.Connection

    objConnection.Open strConnection

    ' get range reference as a string suitable for sql query

    strRangeReference = "[" & rngInput.Parent.Name & "$" & rngInput.Address(False, False) & "]"

    ' get the data ordered by text columns (1 and 2) and values (3)

    strSql = "select * from " & strRangeReference & " order by 13, 9, 3"

    ' populate the recordset

    Set objRecordSet = New ADODB.Recordset

    objRecordSet.Open strSql, objConnection

    ' get the sorted data to the variant

    varSortedData = objRecordSet.GetRows

    ' need to transpose the sorted data

    varSortedData = WorksheetFunction.Transpose(varSortedData)

    ' output the transposed sorted data to target range

    rngOutput.Offset(1, 0).Resize(UBound(varSortedData, 1), UBound(varSortedData, 2)).Value = varSortedData

    ' clean up

    objRecordSet.Close

    Set objRecordSet = Nothing

    objConnection.Close

    Set objConnection = Nothing

End Sub