ولابد ان يكون جميع الصفوف بها بيانات حتى لو كان نقط فقط مثل ....
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