мкр_анализ_массивов

Форум » Программистские штучки » мкр_анализ_массивов » Ответить

мкр_анализ_массивов

Прохожий: В ходе работы надо было мне анализировать массивы скважин из разных мест, т.е. сравнивать, какие есть в обоих списках, какие только в первом, какие только во втором. А тут на работе появился геофизик, который, впрочем, в основном программки пишет. Как оказалось, он примерно такую же прогу написал. Посмотрел я на неё. Мнда... Всё так прилизано и вычищено, всякие мелкие плюшки в виде отображения процентиков выполнения работы. В общем, видно, что делал человек понимающий и первая реакция была "Вах!" Но потом, разобравшись, пришёл к выводу, что не боги горшки обжигают, некоторые места мне откровенно не нравятся. В частности сразу видно, что человек пишет в основном на С, и многие вкусности VBA не использует. Например, в EXCEL часто можно не перетаскивать данные из ячеек в массив, а работать напрямую с ячейками, сортировку, опять таки, использовать встроенную, а не пресловутый "пузырёк". Но это так, лирическое отступление, в конечном итоге мне до подобного расти и расти... на рабочем листе в первой строке шапка: A1 Список1 B1 Список2 C1 D1 Есть в первом, но нет во втором E1 Есть во втором, но нет в первом F1 Есть везде G1 Общий список, без повторов А вот собственно код в авторской редакции, правда я каменты на русском добавил [pre2] 'Автор: Овчинников А.А. '14 февраля 2008г Option Explicit 'Явное объявление переменных Option Base 1 Option Compare Text Type uList list() As String size As Long End Type Type Progress_ msg As String percent As Integer End Type Dim progress As Progress_ Const c_list1 As Integer = 1 Const c_list2 As Integer = 2 Const c_list1exc As Integer = 4 Const c_list2exc As Integer = 5 Const c_and As Integer = 6 Const c_all As Integer = 7 Const r_data_begins As Long = 2 Sub clear() 'Модуль для очистки полей с исходными данными. Для запуска на листе даже кнопка соответствующая есть Range(Chr(65 + c_list1 - 1) + Format(r_data_begins) + ":" + Chr(65 + c_list2 - 1) + Format(Application.Rows.Count)).ClearContents End Sub Public Sub Main() Dim list1 As uList Dim list2 As uList Dim list1exc As uList Dim list2exc As uList Dim list_and As uList Dim list_all As uList Dim i As Long Range(Chr(65 + c_list1exc - 1) + Format(r_data_begins) + ":" + Chr(65 + c_all - 1) _ + Format(Application.Rows.Count)).ClearContents 'очистка выходных полей Info 0, "Загрузка первого списка..." 'прога написания в статус бар uList_Init list1, c_list1, r_data_begins 'в list1 собраны непустые, неповторяющиеся значения из первого столбца Info 0, "Загрузка второго списка..." uList_Init list2, c_list2, r_data_begins uList_Init_sz list1exc, list1.size 'задание размерности соответствующих выходных массивов uList_Init_sz list2exc, list2.size uList_Init_sz list_and, list1.size + list2.size uList_Init_sz list_all, list1.size + list2.size Info 0, "Обработка..." 'Сравниваются все элементы первого списка со всеми элементами второго, при совпадении пишутся в list_and, иначе в list1exc For i = 1 To list1.size If uList_FindItem(list2, list1.list(i)) > 0 Then If uList_FindItem(list_and, list1.list(i)) = 0 Then uList_AddItem list_and, list1.list(i) End If Else uList_AddItem list1exc, list1.list(i) End If Next i 'Сравниваются все элементы второго списка со всеми элементами первого, при совпадении пишутся в list_and, иначе в list2exc 'Следует отметить, сто предусмотрен обход дублирования значений в list_and For i = 1 To list2.size If uList_FindItem(list1, list2.list(i)) > 0 Then If uList_FindItem(list_and, list2.list(i)) = 0 Then uList_AddItem list_and, list2.list(i) End If Else uList_AddItem list2exc, list2.list(i) End If Next i For i = 1 To list1exc.size uList_AddItem list_all, list1exc.list(i) Next i For i = 1 To list2exc.size uList_AddItem list_all, list2exc.list(i) Next i For i = 1 To list_and.size uList_AddItem list_all, list_and.list(i) Next i Info 0, "Сортировка результатов..." uList_BubbleSort list1exc uList_BubbleSort list2exc uList_BubbleSort list_and uList_BubbleSort list_all Info 0, "Вывод..." 'Application.ScreenUpdating = False uList_FastPrint list1exc, c_list1exc, r_data_begins uList_FastPrint list2exc, c_list2exc, r_data_begins uList_FastPrint list_and, c_and, r_data_begins uList_FastPrint list_all, c_all, r_data_begins 'Application.ScreenUpdating = True Info 0, "" End Sub Private Sub uList_Init(list As uList, col As Integer, s_row As Long) Dim in_data_array() As Variant list.size = 0 in_data_array = Range(Chr(65 + col - 1) + Format(s_row) + ":" + Chr(65 + col - 1) + Format(Application.Rows.Count)).Value 'Закинули в переменную все значения первого столбца от А2 до конца листа uList_LoadFromMemory list, in_data_array 'теперь в list.list хранятся непустые, неповторяющиеся значения. Только они не отсортированы End Sub Private Sub uList_Init_sz(list As uList, size As Long) list.size = 0 ReDim list.list(max(size, 1)) End Sub 'Private Function ContLen(col As Integer, s_row As Long) As Long 'ContLen = 0 ' 'Do While Trim(Cells(s_row + ContLen, col)) <> "" ' inc ContLen 'Loop 'End Function Private Sub uList_AddItem(list As uList, item As String) inc list.size list.list(list.size) = item End Sub Private Sub uList_Load(list As uList, col As Integer, ByVal s_row As Long) Dim item As String Do item = Trim(Cells(s_row, col)) If item = "" Then Exit Sub If uList_FindItem(list, item) = 0 Then uList_AddItem list, item inc s_row Loop End Sub Private Function uList_LoadFromMemory(list As uList, data() As Variant) Dim i As Long Dim s As String Dim size As Long Dim m As Long, p As Long 'data, в данном случае, массив прочитанных значений m = (UBound(data, 1) - LBound(data, 1) + 1) * 3 'число ячеек с первой по последнюю в массиве значений *3 p = 0 size = 0 For i = LBound(data, 1) To UBound(data, 1) If Trim(CStr(data(i, 1))) <> "" Then inc size 'определено количество непустых ячеек inc p 'всего количество ячеек, очевидно, для процентиков в статус баре If p Mod 30000 = 0 Then Info p * 100 / m 'как раз обновление статус бара через кажные 30000 ячеек Next i Info 100 ReDim list.list(max(size, 1)) As String 'ниже идёт блок записи данных в выходной массив "list". Отсеиваются пустые ячейки и повторяющиеся значения. For i = LBound(data, 1) To UBound(data, 1) s = Trim(CStr(data(i, 1))) If s <> "" And uList_FindItem(list, s) = 0 Then uList_AddItem list, s 'если ячейка в массиве не пустая и значение в ячейке не встречается в ВЫХОДНОМ массиве, то производится запись выходной inc p, 2 'опять красивости для статус бара If p Mod 30000 <= 1 Then Info p * 100 / m Next i Info 100 'Я вот что думаю. Если сразу провести сортировку средствами excel, то вся эта байда должна работать слегка побыстрее, да и памяти требовать меньше End Function 'прога ищет совпадение во входном массиве и значении переменной, при положительном результате на выходе "1", иначе "0" Private Function uList_FindItem(list As uList, item As String) As Long Dim i As Long For i = 1 To list.size If list.list(i) = item Then uList_FindItem = i Exit Function End If Next i uList_FindItem = 0 End Function 'Private Sub uList_Print(list As uList, t_col As Integer, t_row As Long) 'Dim i As Long ' 'For i = 1 To list.size ' Cells(t_row + i - 1, t_col) = list.list(i) 'Next i 'End Sub Private Sub uList_FastPrint(list As uList, t_col As Integer, t_row As Long) Dim data() As Variant Dim i As Long If list.size = 0 Then Exit Sub ReDim data(list.size, 1) As Variant For i = 1 To list.size data(i, 1) = list.list(i) Next i Range(Chr(65 + t_col - 1) + Format(t_row) + ":" + Chr(65 + t_col - 1) + Format(t_row + list.size - 1)) = data End Sub Private Sub uList_BubbleSort(list As uList) Dim i As Long If list.size <= 1 Then Exit Sub For i = 1 To list.size - 1 If list.list(i) > list.list(i + 1) Then swap list.list(i), list.list(i + 1) i = 0 'Хак цикла. В следующей итерации i = 0 +1 End If Next i End Sub Private Sub inc(x As Variant, Optional add As Variant = 1) x = x + add End Sub Private Sub swap(a As Variant, b As Variant) Dim tmp As Variant tmp = a a = b b = tmp End Sub Private Function max(a As Variant, b As Variant) As Variant max = IIf(a > b, a, b) End Function Private Function Info(Optional pct As Integer = 0, Optional msg As String = "*") Dim update As Boolean progress.percent = pct If msg <> "*" Then progress.msg = msg Application.StatusBar = progress.msg + IIf(pct > 0, Format(pct, " ###") + "%", "") End Function [/pre2]

Ответов - 0

полная версия страницы