Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос на поиск значений из диапазона в другом массиве (диапазоне) данных
 
Всем привет!
Есть следующий кейс: на листе 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
 
Цитата
vadik-ceo написал: ругается на d2 в условии
Видимо потому, что в момент запуска макроса, активным является лист '4'. Для Cells (и для Rows) тоже нужно указывать родительский объект (лист) так же как и для Range.
А потом (когда разберетесь как заполнить массив d2 значениями) лучше загнать массив d2 в СЛОВАРЬ и циклом по массиву d1 проверять наличие его значений в этом словаре (методом .Exists)
Изменено: Sanja - 21 Мар 2018 13:23:07
Согласие есть продукт при полном непротивлении сторон.
 
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 Мар 2018 14:31:47
 
Файл-пример приложите
Согласие есть продукт при полном непротивлении сторон.
 
Sanja,
Там модуль 4. Сейчас код скорректировал, но выдает для всех значений нули....
 
Sanja,
Спасибо за помощь, больше не нужно, разобрался)
Оказалась проблема в формате данных: я искал константы в формулах.
 
Цитата
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
Согласие есть продукт при полном непротивлении сторон.
 
Видимо должна быть сверка со всеми значениями строки... Т.е. словарь здесь, как рыбе зонтик) Наверняка важны и даты, и номера договоров и пр..
Код
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 Мар 2018 15:39:21
 
Цитата
Anchoret написал: Т.е. словарь здесь, как рыбе зонтик
все таки рыбам видать никак без них
Цитата
Anchoret написал: Set Dict = CreateObject("Scripting.Dictionary")
Согласие есть продукт при полном непротивлении сторон.
 
Sanja,зонтики - наше все) Я под этот "зонтик" спрятал в качестве итема номер предполагаемого договора. Потом уже прочитал, чо ТС что-то там тестил и помощь уже не нужна.
Страницы: 1
Читают тему (гостей: 1)