Vba excel сравнить два массива

Аннотация

В этой статье содержатся примеры процедур Microsoft Visual Basic для приложений, которые можно использовать для работы с несколькими типами массивов.

Дополнительная информация

Корпорация Майкрософт предоставляет примеры программирования только для иллюстраций без гарантий, выраженных или подразумеваемых. Это включает, помимо прочего, подразумеваемые гарантии товарной пригодности или пригодности для конкретной цели. В этой статье предполагается, что вы знакомы с демонстрируемым языком программирования и средствами, используемыми для создания и отладки процедур. Инженеры службы поддержки Майкрософт могут помочь объяснить функциональность конкретной процедуры, но они не будут изменять эти примеры, чтобы предоставить дополнительные функциональные возможности или создать процедуры в соответствии с вашими конкретными требованиями. ПРИМЕЧАНИЕ. В Visual Basic для приложений процедурах слова после апострофа (‘) являются комментариями.
 

Заполнение массива и его последующее копирование на лист

  1. Откройте новую книгу и вставьте лист модуля Visual Basic.

  2. Введите следующий код на листе модуля.

    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
    

  3. Выберите Лист1.

  4. В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макросы.

  5. В диалоговом окне Макрос щелкните Sheet_Fill_Array и нажмите кнопку Выполнить.

Для получения значений с листа и заполнения массива

  1. Введите значения на листе 1 в ячейках A1:A10.

  2. На листе модуля 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
    

  3. Выберите Лист1.

  4. В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макросы.

  5. В диалоговом окне Макрос щелкните from_sheet_make_array и нажмите кнопку Выполнить.

Передача и получение массива

  1. На листе модуля введите следующий код:

    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
    

  2. Выберите Лист1 и выделите диапазон A1:A10.

  3. В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макросы.

  4. В диалоговом окне Макрос щелкните pass_array и нажмите кнопку Выполнить.

Сравнение двух массивов

  1. Создайте два именованных диапазона на Листе 1. Назовите один диапазон1, а другой диапазон2.

    Например, выделите диапазон ячеек A1:A10 и назовите его range1; выделите диапазон ячеек B1:B10 и назовите его range2.

  2. Введите следующий код на листе модуля.

    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
    

  3. Выберите Лист2.

  4. В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макрос.

  5. В диалоговом окне Макрос щелкните compare_two_array и нажмите кнопку Выполнить.

    Вы увидите одно окно сообщений для каждого сравнения.

Заполнение динамического массива

  1. На листе модуля введите следующий код:

    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
    

  2. В меню Сервис наведите указатель мыши на пункт Макрос и выберите пункт Макросы.

  3. В диалоговом окне Макрос щелкните 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

Цитата
Сообщение от ikki_cf
Посмотреть сообщение

а что гарантирует уникальность записи в таблицах?
первые три столбца?

пс. у Вас там на Пречистенке чудеса какие-то

Условно да, первые три. Там и не такое бывает))



0



ikki

призрак

3261 / 889 / 119

Регистрация: 11.05.2012

Сообщений: 1,702

Записей в блоге: 2

15.05.2012, 10:22

4

как-то так

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub test()
  Dim ws As Worksheet, a, g, f, dict As Object, aLR&, gLR&, i&
  On Error Resume Next
  
  Set ws = ThisWorkbook.Worksheets("Ëèñò1")
  
  aLR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
  gLR = ws.Cells(ws.Rows.Count, 7).End(xlUp).Row
  a = ws.Range(ws.[a2], ws.Cells(aLR, 3)).Value
  g = ws.Range(ws.[g2], ws.Cells(gLR, 9)).Value
  ReDim f(1 To gLR - 1, 1 To 1)
  
  Set dict = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a, 1)
    dict.Add a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3), ""
  Next
  For i = 1 To UBound(g, 1)
    If Not dict.exists(g(i, 1) & "|" & g(i, 2) & "|" & g(i, 3)) Then f(i, 1) = 1
  Next
  
  ws.Range(ws.[f2], ws.Cells(gLR, 6)).Value = f
End Sub



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

Цитата
Сообщение от ikki_cf
Посмотреть сообщение

и где у вас площадь? я не телепат, сорри
это будет совершенно другой код.
нужен другой подход — и я пока даже не определился, какой именно.
кстати, скорее всего, будет работать на порядок медленнее.

Ой Площадь обозначается в 3-м столбце)



0



призрак

3261 / 889 / 119

Регистрация: 11.05.2012

Сообщений: 1,702

Записей в блоге: 2

15.05.2012, 18:52

8

давайте на всякий случай уточним задачу?
надо:
для каждой записи из «правой» таблицы найти в «левой» таблице хотя бы одну в точности соответствующую ей по первым двум полям запись, причем значение третьего поля должно отличаться не более чем на 3%.
если ни одной такой записи не найдено, то напротив искомой записи слева ставим единичку.

так?



0



0 / 0 / 0

Регистрация: 13.08.2011

Сообщений: 11

15.05.2012, 18:57

 [ТС]

9

Цитата
Сообщение от ikki_cf
Посмотреть сообщение

давайте на всякий случай уточним задачу?
надо:
для каждой записи из «правой» таблицы найти в «левой» таблице хотя бы одну в точности соответствующую ей по первым двум полям запись, причем значение третьего поля должно отличаться не более чем на 3%.
если ни одной такой записи не найдено, то напротив искомой записи слева ставим единичку.

так?

Точно, так



0



ikki

призрак

3261 / 889 / 119

Регистрация: 11.05.2012

Сообщений: 1,702

Записей в блоге: 2

15.05.2012, 19:12

10

проверяйте

Visual Basic
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
Sub test()
  Dim ws As Worksheet, a, g, f, aLR&, gLR&, i&, j&, flag As Boolean
  
  Set ws = ThisWorkbook.Worksheets("Лист1")
  
  aLR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
  gLR = ws.Cells(ws.Rows.Count, 7).End(xlUp).Row
  a = ws.Range(ws.[a2], ws.Cells(aLR, 3)).Value
  g = ws.Range(ws.[g2], ws.Cells(gLR, 9)).Value
  ReDim f(1 To gLR - 1, 1 To 1)
  
  For i = 1 To UBound(g, 1)
    j = 1: flag = False
    Do Until flag Or j > UBound(a, 1)
      If g(i, 1) = a(j, 1) Then
        If g(i, 2) = a(j, 2) Then
          If Abs(a(j, 3) / g(i, 3) - 1) < 0.03 Then flag = True
        End If
      End If
      j = j + 1
    Loop
    If Not flag Then f(i, 1) = 1
  Next
  
  ws.Range(ws.[f2], ws.Cells(gLR, 6)).Value = f
End Sub

как проверите — пожалуйста, сообщите о результатах и, если не трудно — насколько медленнее работает этот макрос по сравнению с предыдущим на реальном объеме данных.



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

Доброго всем времени!
Поделитесь пожалуйста макросом, который будет при своём запуске выдавать окно например: (Выберите первый файл для сравнения), потом следующее, (Выберите второй файл для сравнения). Принцип работы макроса: сравнить два массива на идентичность, с выводом информационного сообщения о проделанной работе — то есть: Результат сравнения — Проверено листов 8, Найдено различий 0, (если есть различия, производится заливка ячеек жёлтым цветом или красным)…
Если есть что то подобное, помогите пожалуйста найти.
Спасибо за Ваше внимание и помощь!



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.

Понравилась статья? Поделить с друзьями:
  • Vba excel сравнение ячейка
  • Vba excel сравнение строковых переменных
  • Vba excel сравнение строк с учетом регистра
  • Vba excel сравнение символов
  • Vba excel сравнение двух столбцов