Аннотация
В этой статье содержатся примеры процедур Microsoft Visual Basic для приложений, которые можно использовать для работы с несколькими типами массивов.
Дополнительная информация
Корпорация Майкрософт предоставляет примеры программирования только для иллюстраций без гарантий, выраженных или подразумеваемых. Это включает, помимо прочего, подразумеваемые гарантии товарной пригодности или пригодности для конкретной цели. В этой статье предполагается, что вы знакомы с демонстрируемым языком программирования и средствами, используемыми для создания и отладки процедур. Инженеры службы поддержки Майкрософт могут помочь объяснить функциональность конкретной процедуры, но они не будут изменять эти примеры, чтобы предоставить дополнительные функциональные возможности или создать процедуры в соответствии с вашими конкретными требованиями. ПРИМЕЧАНИЕ. В Visual Basic для приложений процедурах слова после апострофа (‘) являются комментариями.
Заполнение массива и его последующее копирование на лист
-
Откройте новую книгу и вставьте лист модуля Visual Basic.
-
Введите следующий код на листе модуля.
Sub Sheet_Fill_Array() Dim myarray As Variant myarray = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) Range("a1:a10").Value = Application.Transpose(myarray) End Sub
-
Выберите Лист1.
-
В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макросы.
-
В диалоговом окне Макрос щелкните Sheet_Fill_Array и нажмите кнопку Выполнить.
Для получения значений с листа и заполнения массива
-
Введите значения на листе 1 в ячейках A1:A10.
-
На листе модуля Visual Basic введите следующий код:
Sub from_sheet_make_array() Dim thisarray As Variant thisarray = Range("a1:a10").Value counter = 1 'looping structure to look at array While counter <= UBound(thisarray) MsgBox thisarray(counter, 1) counter = counter + 1 Wend End Sub
-
Выберите Лист1.
-
В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макросы.
-
В диалоговом окне Макрос щелкните from_sheet_make_array и нажмите кнопку Выполнить.
Передача и получение массива
-
На листе модуля введите следующий код:
Sub pass_array() Dim thisarray As Variant thisarray = Selection.Value receive_array (thisarray) End Sub Sub receive_array(thisarray) counter = 1 While counter <= UBound(thisarray) MsgBox thisarray(counter, 1) counter = counter + 1 Wend End Sub
-
Выберите Лист1 и выделите диапазон A1:A10.
-
В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макросы.
-
В диалоговом окне Макрос щелкните pass_array и нажмите кнопку Выполнить.
Сравнение двух массивов
-
Создайте два именованных диапазона на Листе 1. Назовите один диапазон1, а другой диапазон2.
Например, выделите диапазон ячеек A1:A10 и назовите его range1; выделите диапазон ячеек B1:B10 и назовите его range2.
-
Введите следующий код на листе модуля.
Sub compare_two_array() Dim thisarray As Variant Dim thatarray As Variant thisarray = Range("range1").Value thatarray = Range("range2").Value counter = 1 While counter <= UBound(thisarray) x = thisarray(counter, 1) y = thatarray(counter, 1) If x = y Then MsgBox "yes" Else MsgBox "no" End If counter = counter + 1 Wend End Sub
-
Выберите Лист2.
-
В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макрос.
-
В диалоговом окне Макрос щелкните compare_two_array и нажмите кнопку Выполнить.
Вы увидите одно окно сообщений для каждого сравнения.
Заполнение динамического массива
-
На листе модуля введите следующий код:
Sub fill_array() Dim thisarray As Variant number_of_elements = 3 'number of elements in the array 'must redim below to set size ReDim thisarray(1 To number_of_elements) As Integer 'resizes this size of the array counter = 1 fillmeup = 7 For counter = 1 To number_of_elements thisarray(counter) = fillmeup Next counter counter = 1 'this loop shows what was filled in While counter <= UBound(thisarray) MsgBox thisarray(counter) counter = counter + 1 Wend End Sub
-
В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макросы.
-
В диалоговом окне Макрос щелкните fill_array и нажмите кнопку Выполнить.
ПРИМЕЧАНИЕ. Изменение переменной «number_of_elements» определяет размер массива.
Нужна дополнительная помощь?
Edit1: I’ve re-written your loop a bit which is the cause of the problem I think. Ubound and Lbound assumes the first dimension if it is not supplied. So the way you do it and below should return the correct upper and lower bounds. But of course, it is better to be explicit when you’re dealing with 2D arrays. Also vArray3 should be Dimensioned. I didn’t see it in your code. Also added a Boolean variable.
ReDim vArray3 (1 to 10, 1 to 2) '~~> change to suit
Dim dup As Boolean: k = 1
For i = LBound(vArray1, 1) To UBound(vArray1, 1) '~~> specify dimension
dup = False
For j = LBound(vArray2, 1) To UBound(vArray2, 1) '~~> specify dimension
If vArray1(i, 1) = vArray2(j, 1) Then
dup = True: Exit For
End If
Next j
If Not dup Then '~~> transfer if not duplicate
vArray3(k, 1) = vArray1(i, 1)
k = k + 1
End If
Next I
Or you can use match like this:
'~~> Use 1D array instead by using Transpose
vArray2 = Application.Transpose(wb1.Worksheets(2).Range("B1:B" & lRow1))
For i = LBound(vArray1, 1) To UBound(vArray1, 1) '~~> specify dimension
If IsError(Application.Match(vArray1(i, 1), vArray2, 0)) Then
vArray3(k, 1) = vArray1(i, 1)
k = k + 1
End If
Next i
0 / 0 / 0 Регистрация: 13.08.2011 Сообщений: 11 |
|
1 |
|
14.05.2012, 22:52. Показов 31131. Ответов 11
Всем добрый вечер! очень нужна Ваша помощь. Есть два массива (пример приложил, размерность у них условная, на самом деле 10 тыс. и более записей в каждом), если их сравнить, в предыдущем массиве (в январе) произошли изменения (по данным последующего массива один из объектов исчез, он отмечен желтым цветом и обозначен «1»). Возможно сделать макрос для автоматизации этого процесса? Чтобы «ушедшие» объекты как-то выделялись, к примеру, единицами? Опираться при сравнении на цены и бюджеты объектов нельзя, т.к. их колебания условно составляют +-5%. Если конечно это никак нельзя заложить в код…
0 |
призрак 3261 / 889 / 119 Регистрация: 11.05.2012 Сообщений: 1,702 Записей в блоге: 2 |
|
14.05.2012, 23:04 |
2 |
а что гарантирует уникальность записи в таблицах? пс. у Вас там на Пречистенке чудеса какие-то
0 |
0 / 0 / 0 Регистрация: 13.08.2011 Сообщений: 11 |
|
15.05.2012, 10:02 [ТС] |
3 |
а что гарантирует уникальность записи в таблицах? пс. у Вас там на Пречистенке чудеса какие-то Условно да, первые три. Там и не такое бывает))
0 |
ikki призрак 3261 / 889 / 119 Регистрация: 11.05.2012 Сообщений: 1,702 Записей в блоге: 2 |
||||
15.05.2012, 10:22 |
4 |
|||
как-то так
2 |
0 / 0 / 0 Регистрация: 13.08.2011 Сообщений: 11 |
|
15.05.2012, 10:44 [ТС] |
5 |
Круто! Хорошо работает! А можно еще заложить в код изменение площади в районе 3% или это космос получится?
0 |
призрак 3261 / 889 / 119 Регистрация: 11.05.2012 Сообщений: 1,702 Записей в блоге: 2 |
|
15.05.2012, 10:59 |
6 |
и где у вас площадь? я не телепат, сорри
0 |
0 / 0 / 0 Регистрация: 13.08.2011 Сообщений: 11 |
|
15.05.2012, 11:17 [ТС] |
7 |
и где у вас площадь? я не телепат, сорри Ой Площадь обозначается в 3-м столбце)
0 |
призрак 3261 / 889 / 119 Регистрация: 11.05.2012 Сообщений: 1,702 Записей в блоге: 2 |
|
15.05.2012, 18:52 |
8 |
давайте на всякий случай уточним задачу? так?
0 |
0 / 0 / 0 Регистрация: 13.08.2011 Сообщений: 11 |
|
15.05.2012, 18:57 [ТС] |
9 |
давайте на всякий случай уточним задачу? так? Точно, так
0 |
ikki призрак 3261 / 889 / 119 Регистрация: 11.05.2012 Сообщений: 1,702 Записей в блоге: 2 |
||||
15.05.2012, 19:12 |
10 |
|||
проверяйте
как проверите — пожалуйста, сообщите о результатах и, если не трудно — насколько медленнее работает этот макрос по сравнению с предыдущим на реальном объеме данных.
3 |
0 / 0 / 0 Регистрация: 13.08.2011 Сообщений: 11 |
|
16.05.2012, 10:30 [ТС] |
11 |
Спасибо большое! Очень хорошо работает, разница во времени несущественная, на 19 тыс. записей в первом случае это занимает 10 сек, во втором случае около минуты.
0 |
0 / 0 / 0 Регистрация: 03.02.2016 Сообщений: 3 |
|
07.06.2016, 13:11 |
12 |
Доброго всем времени!
0 |
Option Explicit
‘Макросом —
‘1.два диапазона в два массива
‘2.создание массива для результатов
‘3.один перебор n значений массива в словарь
‘4.m проверок массива на наличие в словаре и заполнение данными массива результата
‘5.выгрузка результатов (тут нет предварительной очистки диапазона)
Sub compare()
Dim a(), b(), c(), i As Long, ii As Long
‘1.
a = [d3].CurrentRegion.Value
b = [f3].CurrentRegion.Value
‘2.
ReDim c(1 To UBound(a), 1 To 1)
With CreateObject(«Scripting.Dictionary»)
‘3.
For i = 1 To UBound(b)
.Item(b(i, 1)) = 0&
Next
‘4.
For i = 1 To UBound(a)
If Not .exists(a(i, 1)) Then ii = ii + 1: c(ii, 1) = a(i, 1)
Next
End With
‘5.
[h3].Resize(ii, 1) = c
End Sub
-
#2
I don’t know about more elegant, but it would be quicker to test for inequality and exit the loop when they don’t match.
Code:
x = True
For i = LBound(array1) to UBound(array1)
If array1(i) <> array2(i) Then
x = False
Exit For
End If
Next i
If x = True Then
MsgBox "Match"
Else
MsgBox "Item " & i & " does not match"
End If
-
#3
Yours look more robust to me…. I thought there would be some kind of match commando …quess not.
Thanks !
-
#4
If you don’t need to know which item mismatches you could use the Join function (Excel 2000 and above):
Code:
If Join(array1, "") = Join(array2, "") Then
MsgBox "Match"
Else
MsgBox "Mismatch"
End If
-
#5
hello guys… here i hav a small prb relatd to string arrays.
i have two string arrays as string1=F1,F2,F4,F16,F3
and string2= F2,F11,F7,F8,F12,F3.F21 (these two arrys need not be of same size)
plz suggest me a code to VBE(visual basic editor).
make it asap
thanks….!!!
-
#6
If you don’t need to know which item mismatches you could use the Join function (Excel 2000 and above):
Code:
If Join(array1, "") = Join(array2, "") Then MsgBox "Match" Else MsgBox "Mismatch" End If
I would reccomend to include such separator string (for example, «|» symbol) in Join function that prevents wrong answer.