|
Быстрый поиск в двумерном массиве vba
#39566284
Ссылка:
Ссылка на сообщение:
Ссылка с названием темы:
|
|
|
|
Bobgos,к сожалению тут правильного ответа нет, но зато можете посмотреть как это происходит. В любом случае, мне надо оптимизировать этот код:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
Sub test()
Dim arr1()
Application.ScreenUpdating = False
'range и массив рабочей книги
ncolumn = Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlWhole).Column
Columns(ncolumn + 1).Insert 'вставляем столбец справа
Cells(1, ncolumn + 1).Value = "Карточки" 'вставляем заголовок столбца
m = ActiveSheet.Cells(Rows.Count, ncolumn).End(xlUp).Row
Set rn = ActiveSheet.Cells(2, ncolumn).Resize(m, 2)
arr2 = rn.Value
Set conn = New ADODB.Connection 'Создание соединения
conn.ConnectionString = "Provider=SQLOLEDB.1;Password=132132;Persist Security Info=True;User ID=User;Initial Catalog=dbScanKD;Data Source=SQL05" 'Строка подключения
conn.Open 'Открытие соединения
Set rst = New ADODB.Recordset ' Создание объекта Recordset.
rst.ActiveConnection = conn ' Подключение этого объекта к ранее открытому каналу связи.
Ask = "SELECT DISTINCT [Oboznach] FROM [dbScanKD].[dbo].[vwScanKD] Where Not ([Oboznach] Like '%СБ'or [Oboznach] Like '%ТУ' or [Oboznach] Like '%ИМ' or [Oboznach] Like '%ДИ' or [Oboznach] Like '%РР' or [Oboznach] Like '%РИ' or [Oboznach] Like '%УД' or [Oboznach] Like '%ЛУ' or [Oboznach] Like '%ТБ' or [Oboznach] Like '%Э3' or [Oboznach] Like '%ПЭ3' or [Oboznach] Like '%Д7' or [Oboznach] Like '%К3' or [Oboznach] Like '%Д4' or [Oboznach] Like '%ДП' or [Oboznach] Like '%РИ' or [Oboznach] Like '%ПГ3' or [Oboznach] Like '%ПГ4' or [Oboznach] Like '%Г4' or [Oboznach] Like '%Э4' or [Oboznach] Like '%ТЭ4' or [Oboznach] Like '%ПИ' or [Oboznach] Like '%И2')"
rst.Open Ask, conn, adOpenStatic, adLockBatchOptimistic ' выполняем запрос.
arr1 = rst.GetRows 'закидываем в массив
conn.Close 'закрываем соединение
arr1 = TransposeDim(arr1) 'переворачиваем массив из строк в столбец через функцию TransposeDim с сайта майкрософт
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
If Len(arr2(j, 1)) > 0 Then
If InStr(1, arr1(i, 0), "СБ") > 0 Then
If InStr(arr2(j, 1), "-") > 0 Then
m = Left(arr2(j, 1), InStr(1, arr2(j, 1), "-") - 1) + "СБ"
If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
arr2(j, 2) = arr1(i, 0)
Else
arr2(j, 2) = "нет страниц"
End If
Else
If InStr(1, m, arr1(i, 0), vbTextCompare) > 0 Then
If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
arr2(j, 2) = arr1(i, 0)
Else
arr2(j, 2) = "нет страниц"
End If
End If
End If
Else
If InStr(1, arr2(j, 1) + "СБ", arr1(i, 0), vbTextCompare) > 0 Then
If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
arr2(j, 2) = arr1(i, 0)
Else
arr2(j, 2) = "нет страниц"
End If
End If
End If
Else
If arr2(j, 2) = Empty Then
If InStr(1, arr2(j, 1), arr1(i, 0), vbTextCompare) > 0 Then
For k = 1 To UBound(massoboz)
If InStr(arr2(j, 1), massoboz(k, 1)) > 0 Then
arr2(j, 2) = "нет сборочного"
Exit For
Else
If CInt(arr1(i, 2)) = CInt(arr1(i, 3)) Then 'cравниваем числовые значения
arr2(j, 2) = arr1(i, 0)
Else
arr2(j, 2) = "нет страниц"
End If
End If
Next k
End If
End If
End If
End If
Next j
Next i
ActiveSheet.Cells(2, ncolumn).Resize(UBound(arr2), UBound(arr2, 2)) = arr2'вываливаем на лист
Application.ScreenUpdating = True
End Sub
|
|
|
