Страницы: 1
RSS
Поиск и сопоставление значений и их замена
 
Добрый день!
помогите пожалуйста разобраться с проблемой:
есть список определённых наименований в столбце А, также есть общий список наименований в столбце D и цифровое значение этих наименований в столбце Е. Каким образом можно провести сопоставление наименований из столбца А со столбцом D, и при совпадении взять цифровое значение этого наименования из столбца Е, и далее скопировать его на против начального наименования в столбце В.
Понимаю, что может где то на форуме подобное уже обсуждалось, но к сожалению я не нашёл подобного вопросит решения
 
Функция ВПР Вам в помощь, для наглядности приложите пример.
 
Можно ли это сделать макросом?
 
файл
 
Ford2018, куда посмотреть?
 
выложил файл
 
Ford2018, в ячейку B1
Код
=ВПР(A1;$D$1:$E$154;2;0)
 
Код
Sub Main()
    Dim d As Variant
    d = GetArr(4)
    Dim dic As Object
    Set dic = GetDic(d)
    
    Dim a As Variant
    a = GetArr(1)
    
    FillArr a, dic
    
    Cells(1, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub
'
Function GetArr(c As Integer) As Variant
    Dim y As Long
    y = Cells(Rows.Count, c).End(xlUp).Row
    GetArr = Range(Cells(1, c), Cells(y, c + 1))
End Function
'
Function GetDic(a As Variant) As Object
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    
    Dim y As Long
    For y = 1 To UBound(a, 1)
        d.Item(a(y, 1)) = a(y, 2)
    Next
    
    Set GetDic = d
End Function
'
Sub FillArr(a As Variant, dic As Object)
    Dim y As Long
    For y = 1 To UBound(a, 1)
        If dic.Exists(a(y, 1)) Then
            a(y, 2) = dic.Item(a(y, 1))
        End If
    Next
End Sub
 
Благодарю! А макросом возможно?
В ячейки А могут быть разное количество наименований, но в столбце D количество постоянное
 
Код
Sub Main()
    Dim d As Variant
    d = GetArr(4)
    Dim dic As Object
    Set dic = GetDic(d)
     
    Dim a As Variant
    a = GetArr(1)
     
    FillArr a, dic
     
    Cells(1, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub
'
Function GetArr(c As Integer) As Variant
    Dim y As Long
    y = Cells(Rows.Count, c).End(xlUp).Row
    GetArr = Range(Cells(1, c), Cells(y, c + 1))
End Function
'
Function GetDic(a As Variant) As Object
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
     
    Dim y As Long
    For y = 1 To UBound(a, 1)
        d.Item(UCase(a(y, 1))) = a(y, 2)
    Next
     
    Set GetDic = d
End Function
'
Sub FillArr(a As Variant, dic As Object)
    Dim y As Long
    For y = 1 To UBound(a, 1)
        If dic.Exists(UCase(a(y, 1))) Then
            a(y, 2) = dic.Item(UCase(a(y, 1)))
        Else
            a(y, 2) = Empty
        End If
    Next
End Sub

По просьбе ТС, убрал чувствительность к регистру.
 
Цитата
МатросНаЗебре написал:
убрал чувствительность к регистру.
- почему не просто d.comparemode=1?
Изменено: Hugo - 19.03.2020 20:22:18
 
Цитата
Hugo написал:
почему не просто d.comparemode=1?
Подозревал, что такое есть. Теперь знаю точно. Возьму на вооружение. )
 
Цитата
Hugo: почему не просто d.comparemode=1?
возможно, вариант через UCase будет быстрее - надо тестить…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх