Sorting a multidimensionnal array in VBA -
i have defined following array dim myarray(10,5) long , sort it. best method that?
i need handle lot of data 1000 x 5 matrix. contains numbers , dates , need sort according column
here's multi-column , single-column quicksort vba, modified code sample posted jim rech on usenet.
notes:
you'll notice lot more defensive coding you'll see in of code samples out there on web: excel forum, , you've got anticipate nulls , empty values... or nested arrays , objects in arrays if source array comes (say) third-party realtime market data source.
empty values , invalid items sent end of list.
your call be:
quicksort myarray,,,2...passing '2' column sort on , excluding optional parameters pass upper , lower bounds of search domain.
[edited] - fixed odd formatting glitch in <code> tags, seem have problem hyperlinks in code comments.
the hyperlink excised detecting array variant in vba.
public sub quicksortarray(byref sortarray variant, optional lngmin long = -1, optional lngmax long = -1, optional lngcolumn long = 0) on error resume next 'sort 2-dimensional array ' sampleusage: sort arrdata contents of column 3 ' ' quicksortarray arrdata, , , 3 ' 'posted jim rech 10/20/98 excel.programming 'modifications, nigel heffernan: ' ' escape failed comparison empty variant ' ' defensive coding: check inputs dim long dim j long dim varmid variant dim arrrowtemp variant dim lngcoltemp long if isempty(sortarray) exit sub end if if instr(typename(sortarray), "()") < 1 'isarray() broken: brackets in type name exit sub end if if lngmin = -1 lngmin = lbound(sortarray, 1) end if if lngmax = -1 lngmax = ubound(sortarray, 1) end if if lngmin >= lngmax ' no sorting required exit sub end if = lngmin j = lngmax varmid = empty varmid = sortarray((lngmin + lngmax) \ 2, lngcolumn) ' send 'empty' , invalid data items end of list: if isobject(varmid) ' note don't check isobject(sortarray(n)) - varmid *might* pick valid default member or property = lngmax j = lngmin elseif isempty(varmid) = lngmax j = lngmin elseif isnull(varmid) = lngmax j = lngmin elseif varmid = "" = lngmax j = lngmin elseif vartype(varmid) = vberror = lngmax j = lngmin elseif vartype(varmid) > 17 = lngmax j = lngmin end if while <= j while sortarray(i, lngcolumn) < varmid , < lngmax = + 1 wend while varmid < sortarray(j, lngcolumn) , j > lngmin j = j - 1 wend if <= j ' swap rows redim arrrowtemp(lbound(sortarray, 2) ubound(sortarray, 2)) lngcoltemp = lbound(sortarray, 2) ubound(sortarray, 2) arrrowtemp(lngcoltemp) = sortarray(i, lngcoltemp) sortarray(i, lngcoltemp) = sortarray(j, lngcoltemp) sortarray(j, lngcoltemp) = arrrowtemp(lngcoltemp) next lngcoltemp erase arrrowtemp = + 1 j = j - 1 end if wend if (lngmin < j) call quicksortarray(sortarray, lngmin, j, lngcolumn) if (i < lngmax) call quicksortarray(sortarray, i, lngmax, lngcolumn) end sub ... , single-column array version:
public sub quicksortvector(byref sortarray variant, optional lngmin long = -1, optional lngmax long = -1) on error resume next 'sort 1-dimensional array ' sampleusage: sort arrdata ' ' quicksortvector arrdata ' ' posted jim rech 10/20/98 excel.programming ' modifications, nigel heffernan: ' ' escape failed comparison empty variant in array ' ' defensive coding: check inputs dim long dim j long dim varmid variant dim varx variant if isempty(sortarray) exit sub end if if instr(typename(sortarray), "()") < 1 'isarray() broken: brackets in type name exit sub end if if lngmin = -1 lngmin = lbound(sortarray) end if if lngmax = -1 lngmax = ubound(sortarray) end if if lngmin >= lngmax ' no sorting required exit sub end if = lngmin j = lngmax varmid = empty varmid = sortarray((lngmin + lngmax) \ 2) ' send 'empty' , invalid data items end of list: if isobject(varmid) ' note don't check isobject(sortarray(n)) - varmid *might* pick default member or property = lngmax j = lngmin elseif isempty(varmid) = lngmax j = lngmin elseif isnull(varmid) = lngmax j = lngmin elseif varmid = "" = lngmax j = lngmin elseif vartype(varmid) = vberror = lngmax j = lngmin elseif vartype(varmid) > 17 = lngmax j = lngmin end if while <= j while sortarray(i) < varmid , < lngmax = + 1 wend while varmid < sortarray(j) , j > lngmin j = j - 1 wend if <= j ' swap item varx = sortarray(i) sortarray(i) = sortarray(j) sortarray(j) = varx = + 1 j = j - 1 end if wend if (lngmin < j) call quicksortvector(sortarray, lngmin, j) if (i < lngmax) call quicksortvector(sortarray, i, lngmax) end sub i used use bubblesort kind of thing, slows down, severely, after array exceeds 1024 rows. include code below reference: please note haven't provided source code arraydimensions, not compile unless refactor - or split out 'array' , 'vector' versions.
public sub bubblesort(byref inputarray, optional sortcolumn integer = 0, optional descending boolean = false) ' sort 1- or 2-dimensional array. dim ifirstrow integer dim ilastrow integer dim ifirstcol integer dim ilastcol integer dim integer dim j integer dim k integer dim vartemp variant dim outputarray variant dim idimensions integer idimensions = arraydimensions(inputarray) select case idimensions case 1 ifirstrow = lbound(inputarray) ilastrow = ubound(inputarray) = ifirstrow ilastrow - 1 j = + 1 ilastrow if inputarray(i) > inputarray(j) vartemp = inputarray(j) inputarray(j) = inputarray(i) inputarray(i) = vartemp end if next j next case 2 ifirstrow = lbound(inputarray, 1) ilastrow = ubound(inputarray, 1) ifirstcol = lbound(inputarray, 2) ilastcol = ubound(inputarray, 2) if sortcolumn inputarray(j, sortcolumn) k = ifirstcol ilastcol vartemp = inputarray(j, k) inputarray(j, k) = inputarray(i, k) inputarray(i, k) = vartemp next k end if next j next end select if descending outputarray = inputarray = lbound(inputarray, 1) ubound(inputarray, 1) k = 1 + ubound(inputarray, 1) - j = lbound(inputarray, 2) ubound(inputarray, 2) inputarray(i, j) = outputarray(k, j) next j next erase outputarray end if end sub
this answer may have arrived bit late solve problem when needed to, other people pick when google answers similar problems.
Comments
Post a Comment