В ходе работы надо было мне анализировать массивы скважин из разных мест, т.е. сравнивать, какие есть в обоих списках, какие только в первом, какие только во втором. А тут на работе появился геофизик, который, впрочем, в основном программки пишет. Как оказалось, он примерно такую же прогу написал. Посмотрел я на неё. Мнда... Всё так прилизано и вычищено, всякие мелкие плюшки в виде отображения процентиков выполнения работы. В общем, видно, что делал человек понимающий и первая реакция была "Вах!" Но потом, разобравшись, пришёл к выводу, что не боги горшки обжигают, некоторые места мне откровенно не нравятся. В частности сразу видно, что человек пишет в основном на С, и многие вкусности VBA не использует. Например, в EXCEL часто можно не перетаскивать данные из ячеек в массив, а работать напрямую с ячейками, сортировку, опять таки, использовать встроенную, а не пресловутый "пузырёк". Но это так, лирическое отступление, в конечном итоге мне до подобного расти и расти...
на рабочем листе в первой строке шапка:
A1 Список1
B1 Список2
C1
D1 Есть в первом, но нет во втором
E1 Есть во втором, но нет в первом
F1 Есть везде
G1 Общий список, без повторов
А вот собственно код в авторской редакции, правда я каменты на русском добавил
'Автор: Овчинников А.А.
'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
- участник сейчас на форуме
- участник вне форума
