Наши проекты:
Журнал · Discuz!ML · Wiki · DRKB · Помощь проекту |
||
ПРАВИЛА | FAQ | Помощь | Поиск | Участники | Календарь | Избранное | RSS |
[54.221.159.188] |
|
Сообщ.
#1
,
|
|
|
Доброго времени суток! Есть сортировка. Она работает идеально только в случае, когда один столбец (в массиве кроме числе больше ничего нет).
У меня данные в таком виде: массив dat_ls 01.01.2028 01.01.2017 123 01.02.2014 05.07.2014 456 01.05.2026 07.01.2019 000 Надо отсортировать данные по 1-му или 2-му столбцу так, чтобы данные сохранились (как в EXCEL). А данные сохраняются только в том столбце, который сортируется. Помогите, пожалуйста, как мне видоизменить код, чтобы данные совместно сортировались? 'Запуск сортировки-------------------------------------- Dim dt1() As String dt1 = SortArrayMinMaxZnV1(dat_ls, 0, 1, 0) '//Запуск сортировки------------------------------------ 'Сам код-------------------------------------- Public Function SortArrayMinMaxZnV1(ByRef in_arr() As String, ByVal MinMax As LogVar, ByVal NmbStlb As Byte, ByVal SW_Type As Boolean) As String() 'SW_Type=1 - сортировка по числам, 0- по дате Dim max_val As Variant Dim i As Long Dim x As Long Dim m As Long Dim tmp As Variant Dim tmp1 As String m = 0 x = 0 If MinMax = 0 Then 'минимум If SW_Type = 0 Then max_val = CDate("01.01.4099") Else max_val = Val(10000) End If Else If SW_Type = 0 Then max_val = CDate("01.01.1099") Else max_val = Val(-9999) End If End If M4: For i = m To UBound(in_arr) tmp = ParseStrDIV(Chr(9) & in_arr(i) & Chr(9), Chr(9), Chr(9), NmbStlb - 1) If MinMax = 0 Then 'минимум If SW_Type = 0 Then tmp = CDate(tmp) Else tmp = Val(tmp) End If If (tmp < max_val) Then max_val = tmp x = i End If Else If (tmp > max_val) Then max_val = tmp x = i End If End If Next i in_arr(x) = in_arr(m) in_arr(m) = ReplaceCell_InStr(in_arr(m), NmbStlb, CStr(max_val)) If MinMax = 0 Then 'минимум If SW_Type = 0 Then max_val = CDate("01.01.4099") Else max_val = Val(10000) End If Else If SW_Type = 0 Then max_val = CDate("01.01.1099") Else max_val = Val(-9999) End If End If m = m + 1 If m <= UBound(in_arr) Then GoTo M4 SortArrayMinMaxZnV1 = in_arr End Function Public Function ParseStrDIV(ByVal sourc_str As String, ByVal str_div1 As String, ByVal str_div2 As String, ByVal PN As Integer) As String Dim p As Integer Dim m As Integer PN = PN + 1 If str_div1 = vbNullString Then m = 1 GoTo M4 End If If str_div2 = vbNullString Then p = Len(sourc_str) m = CountInSTR(sourc_str, str_div1, PN) + 1 ParseStrDIV = Mid(sourc_str, m, p) Exit Function End If m = CountInSTR(sourc_str, str_div1, PN) + 1 M4: If m = 1 Then p = CountInSTR(sourc_str, str_div2, PN) + 1 Else p = CountInSTR(sourc_str, str_div2, PN + 1) + 1 If m > p Then p = CountInSTR(sourc_str, str_div2, PN - 1) + 1 End If If m = p Then ParseStrDIV = Mid(sourc_str, m, Len(sourc_str) - m + 1) Else If Len(str_div1) > 1 And Len(str_div2) > 1 Then ParseStrDIV = Mid(sourc_str, Len(str_div1) + 1, p - Len(str_div2) - 1) Else ParseStrDIV = Mid(sourc_str, m, p - m - 1) End If End If End Function Public Function ReplaceCell_InStr(ByVal str_dat As String, ByVal NumbStlb As Byte, ByVal repl_dat As String) As String Dim i As Long Dim lft_s As String Dim rgt_s As String Dim sum_s As String 'Dim tmp_s As String 'Dim len_str As Integer 'str_dat = Chr(9) & str_dat & Chr(9) 'If NumbStlb = 1 Then NumbStlb = 0 'len_str = CountInSTR(str_dat, Chr(9), NumbStlb) lft_s = ParseStrDIV(Chr(9) & str_dat, vbNullString, Chr(9), NumbStlb - 1) 'If NumbStlb = 0 Then NumbStlb = 1 rgt_s = ParseStrDIV(Chr(9) & str_dat & Chr(9), Chr(9), vbNullString, NumbStlb) sum_s = Replace(lft_s & Chr(9) & repl_dat & Chr(9) & rgt_s, Chr(9) & Chr(9), Chr(9)) 'if 'If ParseStrDIV(sum_s, Chr(9), vbNullString, 0) = Chr(9) Then sum_s = Left(sum_s, Len(sum_s) - 1) 'If ParseStrDIV(sum_s, vbNullString, Chr(9), 0) = Chr(9) Then sum_s = Right(sum_s, Len(sum_s) - 1) ReplaceCell_InStr = sum_s 'Replace(lft_s & Chr(9) & repl_dat & Chr(9) & rgt_s, Chr(9) & Chr(9), Chr(9)) End Function Public Function CountInSTR(ByVal str As String, ByVal find_str As String, Optional ByVal p_numb As Long = 0) As Long Dim x As Long Dim cnt_count As Long Dim tmp_temp As Long 'x = InStr(1, str, find_str) ' p_numb - ģīęķī óźąēąņü ķīģåš żėåģåķņą ļī ń÷øņó ā ńņšīźå, ÷ņīįū ļīėó÷čņü äėčķó äī ķåćī 'Dim y As Long If p_numb = 0 Then p_numb = Len(str) For x = 1 To p_numb 'Len(str) cnt_count = InStr(cnt_count + 1, str, find_str) If cnt_count = 0 Then Exit For tmp_temp = cnt_count 'y = y + 1 Next x CountInSTR = tmp_temp End Function '//Сам код------------------------------------ |
Сообщ.
#2
,
|
|
|
Не, вот ты всерьёз думаешь, что кто-то станет разбираться в этой твоей некомментированной и неформатированной портянке?
|
Сообщ.
#3
,
|
|
|
Цитата Akina @ Не, вот ты всерьёз думаешь, что кто-то станет разбираться в этой твоей некомментированной и неформатированной портянке? тут только 1 ф-я отвечает за сортировку, остальные можно не смотреть, они служебные, я их для компиляции дал Public Function SortArrayMinMaxZnV1(ByRef in_arr() As String, ByVal MinMax As LogVar, ByVal NmbStlb As Byte, ByVal SW_Type As Boolean) As String() 'SW_Type=1 - сортировка по числам, 0- по дате Dim max_val As Variant Dim i As Long Dim x As Long Dim m As Long Dim tmp As Variant Dim tmp1 As String m = 0 x = 0 If MinMax = 0 Then 'минимум If SW_Type = 0 Then max_val = CDate("01.01.4099") Else max_val = Val(10000) End If Else If SW_Type = 0 Then max_val = CDate("01.01.1099") Else max_val = Val(-9999) End If End If M4: For i = m To UBound(in_arr) tmp = ParseStrDIV(Chr(9) & in_arr(i) & Chr(9), Chr(9), Chr(9), NmbStlb - 1) If MinMax = 0 Then 'минимум If SW_Type = 0 Then tmp = CDate(tmp) Else tmp = Val(tmp) End If If (tmp < max_val) Then max_val = tmp x = i End If Else If (tmp > max_val) Then max_val = tmp x = i End If End If Next i in_arr(x) = in_arr(m) in_arr(m) = ReplaceCell_InStr(in_arr(m), NmbStlb, CStr(max_val)) If MinMax = 0 Then 'минимум If SW_Type = 0 Then max_val = CDate("01.01.4099") Else max_val = Val(10000) End If Else If SW_Type = 0 Then max_val = CDate("01.01.1099") Else max_val = Val(-9999) End If End If m = m + 1 If m <= UBound(in_arr) Then GoTo M4 SortArrayMinMaxZnV1 = in_arr End Function |
Сообщ.
#4
,
|
|
|
ByRef in_arr() As String А на что тебе ООП? Загнал бы всё в модель Row а не в виде строк... |
Сообщ.
#5
,
|
|
|
Ну да, стало короче. Теперь ещё исправить бы вот эти недостатки:
Цитата Akina @ некомментированной Цитата Akina @ неформатированной Ну и хотя бы указать, какой из многочисленных методов сортировки тут использован. И какой используется формат входных данных. Хотя я бы предложил всё это нахрен выбросить и сделать заново. Ориентируясь на сортировку пользовательского типа данных (это может быть и массив пользовательского типа, и многомерный массив, и сериализованная строка, и вообще что угодно), для чего достаточно к любому стандартному коду сортировки добавить два кусочка (функцию сравнения двух элементов и процедуру их обмена) и использовать их в соотв. местах кода. |
Сообщ.
#6
,
|
|
|
Добавлено
Цитата VisualProg @ ByRef in_arr() As String А на что тебе ООП? Загнал бы всё в модель Row а не в виде строк... не совсем знаком с этим, плюс не хотел заморачиваться Добавлено Цитата Akina @ Ну да, стало короче. Теперь ещё исправить бы вот эти недостатки: Цитата Akina @ некомментированной Цитата Akina @ неформатированной Ну и хотя бы указать, какой из многочисленных методов сортировки тут использован. И какой используется формат входных данных. Хотя я бы предложил всё это нахрен выбросить и сделать заново. Ориентируясь на сортировку пользовательского типа данных (это может быть и массив пользовательского типа, и многомерный массив, и сериализованная строка, и вообще что угодно), для чего достаточно к любому стандартному коду сортировки добавить два кусочка (функцию сравнения двух элементов и процедуру их обмена) и использовать их в соотв. местах кода. не мой код, я думаю, хотя не помню уже |
Сообщ.
#7
,
|
|
|
Цитата salieri @ не совсем знаком с этим, плюс не хотел заморачиваться ИМХО, в этом то и проблема Половина твоего метода - это парсинг и преобразования, а не сортировка. Так, что, я бы сказал - основная ошибка в том, что это винегрет а не функция сортировки. Если ты сделаешь модель записи - парсить данные будет другой код/функция/модуль класса. Сортировать такие модели записи куда проще, и да, на выходе, ты получишь универсальную сортировку, хоть по первому столбцу, хоть по 10, хоть по двум столбцам одновременно - всё это можно будет решить, подавая на сортировщик только те данные, которые надо сравнивать. (для этого надо будет оперировать функцией-компаратором) |
Сообщ.
#8
,
|
|
|
такой вариант предложили мне.
Sub Sort_(Arr() As String, nCol As Integer) s% = LBound(Arr, 1) e% = UBound(Arr, 1) For i% = s% To e% - 1 For j% = i% + 1 To e% If CDate(Arr(i%, nCol%)) > CDate(Arr(j%, nCol%)) Then For k% = LBound(Arr, 2) To UBound(Arr, 2) tmp$ = Arr(i%, k%) Arr(i%, k%) = Arr(j%, k%) Arr(j%, k%) = tmp$ Next k% End If Next j% Next i% End Sub Sub Test() Dim X(1 To 3, 1 To 3) As String X(1, 1) = "01.01.2028" X(1, 2) = "01.01.2017" X(1, 3) = "123" X(2, 1) = "01.02.2014" X(2, 2) = "05.07.2014" X(2, 3) = "456" X(3, 1) = "01.05.2026" X(3, 2) = "07.01.2019" X(3, 3) = "000" Debug.Print "Сортировка по 1-й колонке" Debug.Print Sort_ X, 1 For i% = 1 To 3 For j% = 1 To 3 Debug.Print X(i%, j%); " "; Next j% Debug.Print Next i% Debug.Print Debug.Print "Сортировка по 2-й колонке" Debug.Print Sort_ X, 2 For i% = 1 To 3 For j% = 1 To 3 Debug.Print X(i%, j%); " "; Next j% Debug.Print Next i% Debug.Print End Sub |
Сообщ.
#9
,
|
|
|
Цитата VisualProg @ (для этого надо будет оперировать функцией-компаратором) Рисовать на VB непривязанные коллбэки - неблагодарное занятие... |
Сообщ.
#10
,
|
|
|
Что хотел, написал. Всем спасибо за помощь! Я очень благодарен.
Public Function SortArray(ByRef in_arr() As String, ByVal MinMax As LogVar, ByVal NumStlb As Byte, ByVal SW_Type As LogVar) As String() 'SW_Type=0 - сортировка по числам, 1- по дате 'MinMax=0 - убывание, 1 - возрастание Dim m As Long Dim x As Variant Dim i As Long Dim tmp_i As Long Dim tmp_s As String Dim sourc_in_arr() As String ReDim sourc_in_arr(UBound(in_arr)) As String For i = 0 To UBound(in_arr) sourc_in_arr(i) = in_arr(i) Next i 'Erase ArrDat Del_ArrDat tmp_i = 0 'x = 0 m = 0 'If in_arr(tmp_i) <> vbNullString Then x = Val(in_arr(tmp_i)) NumStlb = NumStlb - 1 '-1 M4: If MinMax = 0 Then If SW_Type = 0 Then x = Val(-999999) Else x = CDate("01.01.1900") End If Else If SW_Type = 0 Then x = Val(999999) Else x = CDate("01.01.2090") End If End If 'MsgBox in_arr(7) For i = 0 To UBound(sourc_in_arr) tmp_s = ParseStrDIV_V1(Chr(9) & sourc_in_arr(i) & Chr(9), Chr(9), Chr(9), NumStlb, NumStlb) If tmp_s <> vbNullString Then If MinMax = 0 Then If SW_Type = 0 Then If Val(tmp_s) > Val(x) Then x = Val(tmp_s) tmp_i = i End If Else If CDate(tmp_s) > CDate(x) Then x = CDate(tmp_s) tmp_i = i End If End If Else If SW_Type = 0 Then If Val(tmp_s) < Val(x) Then x = Val(tmp_s) tmp_i = i End If Else If CDate(tmp_s) < CDate(x) Then x = CDate(tmp_s) tmp_i = i End If End If End If End If Next i '''ReplaceCell_InStr in_arr(tmp_i), NumStlb, vbNullString 'CStr(x) '''in_arr(tmp_i) = vbNullString Add_ArrDat sourc_in_arr(tmp_i) 'CStr(x) sourc_in_arr(tmp_i) = vbNullString m = m + 1 If m <= UBound(sourc_in_arr) Then GoTo M4 SortArray = ArrDat '_OUT End Function Public Function ParseStrDIV_V1(ByVal sourc_str As String, ByVal str_div1 As String, ByVal str_div2 As String, ByVal PN1 As Integer, ByVal PN2 As Integer) As String '() Dim p As Integer Dim m As Integer PN1 = PN1 + 1 PN2 = PN2 + 1 If str_div1 = vbNullString Then m = 1 GoTo M4 End If If str_div2 = vbNullString Then p = Len(sourc_str) m = CountInSTR(sourc_str, str_div1, PN1) + 1 ParseStrDIV_V1 = Mid(sourc_str, m, p) Exit Function End If m = CountInSTR(sourc_str, str_div1, PN1) + 1 M4: If m = 1 Then p = CountInSTR(sourc_str, str_div2, PN2) + 1 Else p = CountInSTR(sourc_str, str_div2, PN2 + 1) + 1 If m > p Then p = CountInSTR(sourc_str, str_div2, PN1 - 1) + 1 End If If m = p Then ParseStrDIV_V1 = Mid(sourc_str, m, Len(sourc_str) - m + 1) Else If Len(str_div1) > 1 And Len(str_div2) > 1 Then ParseStrDIV_V1 = Mid(sourc_str, Len(str_div1) + 1, p - Len(str_div2) - 1) Else ParseStrDIV_V1 = Mid(sourc_str, m, p - m - 1) End If End If End Function Public Sub Del_ArrDat() 'As String() 'Static count_arr As Long ReDim ArrDat(0) As String ArrDat(0) = vbNullString 'var_dat 'count_arr = count_arr + 1 Erase ArrDat 'AddArrDat = ArrDat End Sub Public Sub Add_ArrDat(ByVal var_dat As String) 'As String() Static count_arr As Long ReDim Preserve ArrDat(count_arr) As String ArrDat(count_arr) = var_dat count_arr = count_arr + 1 'AddArrDat = ArrDat End Sub |