Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос на поиск значений из диапазона в другом массиве (диапазоне) данных
 
#1
21.03.2018 13:00:25
Всем привет!
Есть следующий кейс: на листе 3 располагаются некоторые ключи в определенном столбце. Мне нужно проверить каждое значение в этом столбце в массиве (или диапазоне, не уверен как будет верно) данных на другом листе. Если встречается данное значение, то в соседнем столбце проставить 0, если нет 1.
Написал следующее, к сожалению, выдает ошибку invalid qualifier (ругается на d2 в условии). Прошу помощи.
Код
Sub UniqueValues()
Dim d1(), d2()
lLastrow = Sheets("3").Cells(Rows.Count, 1).End(xlUp).Row
d1 = Sheets("4").Range("H2", Cells(Rows.Count, 8).End(xlUp))
d2 = Sheets("3").Range("I2", Cells(Rows.Count, 9).End(xlUp))
For j = 1 To lLastrow - 1
    If d2.Cells(j + 1, 9).Value = d1.Cells(j + 1, 8).Value Then Sheets("3").Cells(j + 1, 10) = 0 Else Sheets("3").Cells(j + 1, 10) = 1
Next
End Sub
 
 
 
#2
21.03.2018 13:22:35
Цитата
vadik-ceo написал: ругается на d2 в условии
Видимо потому, что в момент запуска макроса, активным является лист '4'. Для Cells (и для Rows) тоже нужно указывать родительский объект (лист) так же как и для Range.
А потом (когда разберетесь как заполнить массив d2 значениями) лучше загнать массив d2 в СЛОВАРЬ и циклом по массиву d1 проверять наличие его значений в этом словаре (методом .Exists)
Изменено: Sanja - 21.03.2018 13:23:07
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
21.03.2018 14:31:36
Sanja, честно говоря, не понимаю, почему из-за листа вылезает ошибка...
Сейчас немного скорректировал код, вылезает дебаг на d1. Не могли бы подсказать в чем проблема?
Код
Sub UniqueValues()
Dim d1 As Range
lLastrow = Sheets("3").Cells(Rows.Count, 1).End(xlUp).Row
d1 = Sheets("4").Range("H2", Cells(Rows.Count, 8).End(xlUp))
For j = 1 To lLastrow - 1
    If d1.Find(Cells(j + 1, 9), , , xlWhole) Is Nothing Then Sheets("3").Cells(j + 1, 10) = 0 Else Sheets("3").Cells(j + 1, 10) = 1
Next
End Sub
Изменено: vadik-ceo - 21.03.2018 14:31:47
 
 
 
#4
21.03.2018 14:38:15
Файл-пример приложите
Согласие есть продукт при полном непротивлении сторон
 
 
 
#5
21.03.2018 14:41:11
Sanja,
Там модуль 4. Сейчас код скорректировал, но выдает для всех значений нули....
 
 
 
#6
21.03.2018 14:48:31
Sanja,
Спасибо за помощь, больше не нужно, разобрался)
Оказалась проблема в формате данных: я искал константы в формулах.
 
 
 
#7
21.03.2018 14:58:50
Цитата
vadik-ceo написал: но выдает для всех значений нули.
Так а что там должно быть, если
Цитата
vadik-ceo написал: Если встречается данное значение, то в соседнем столбце проставить 0
ВСЕ значения в столбце 'H' листе '4' встречаются в столбце 'I' листа '3'
Мой макрос тоже дает все нули по той же самой причине
Код
Sub UniqueValues()
Dim d1(), d2(), I&, lRow&, iTemp
Dim dic As Object
On Error Resume Next
With Worksheets("3")
    d1 = .Range("I2:I" & .Cells(.Rows.Count, "I").End(xlUp).Row).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(d1)
    iTemp = dic(CStr(d1(I, 1)))
Next
With Worksheets("4")
    d2 = .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row).Value
End With
ReDim Preserve d2(1 To UBound(d2, 1), 1 To 2)
For I = 1 To UBound(d2)
    d2(I, 2) = IIf(dic.Exists(CStr(d2(I, 1))), 0, 1)
Next
With Worksheets("4")
    lRow = IIf(.Cells(.Rows.Count, "H").End(xlUp).Row < 2, 2, .Cells(.Rows.Count, "H").End(xlUp).Row)
    .Range("H2:H" & lRow).ClearContents
    .Range("H2").Resize(UBound(d2), 2) = d2
End With
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#8
21.03.2018 15:20:52
Видимо должна быть сверка со всеми значениями строки... Т.е. словарь здесь, как рыбе зонтик) Наверняка важны и даты, и номера договоров и пр..
Код
Sub UniqueValues()
Dim p1 As Long, p2 As String, p3 As Long, p4 As String
Dim d1 As Range, llastrow&, i&
Dim arr(), Dict As Object
llastrow = Sheets("3").Cells(Rows.Count, 1).End(xlUp).Row
arr = Sheets("3").Range("A2:J" & llastrow).Value
Set Dict = CreateObject("Scripting.Dictionary")
For Each d1 In Sheets("4").Range("H2:H10")
    If Not Dict.exists(d1.Value) Then Dict.Add d1.Value, d1.Offset(, -2).Value
Next
For i = 1 To UBound(arr, 1)
    p1 = arr(i, 1)
    p2 = arr(i, 3)
    p3 = arr(i, 7)
    arr(i, 9) = p1 & " " & p2 & " " & p3
    If Dict.exists(arr(i, 9)) Then
      If arr(i, 6) = Dict.Item(arr(i, 9)) Then arr(i, 10) = 1 Else arr(i, 10) = 0
    End If
Next
Sheets("3").[a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr 'убьет формулы в столбце "H"
End Sub
Изменено: Anchoret - 21.03.2018 15:39:21
 
 
 
#9
21.03.2018 17:48:25
Цитата
Anchoret написал: Т.е. словарь здесь, как рыбе зонтик
все таки рыбам видать никак без них
Цитата
Anchoret написал: Set Dict = CreateObject("Scripting.Dictionary")
Согласие есть продукт при полном непротивлении сторон
 
 
 
#10
21.03.2018 21:13:40
Sanja,зонтики - наше все) Я под этот "зонтик" спрятал в качестве итема номер предполагаемого договора. Потом уже прочитал, чо ТС что-то там тестил и помощь уже не нужна.
 
 
 
Страницы: 1
Наверх