Сопоставление ключей словаря со значениями ячеек листа - PullRequest
Новая
       8

Сопоставление ключей словаря со значениями ячеек листа

0 голосов
/ 10 июля 2020

Я еще не нашел никаких вопросов, связанных с этим топом c, поэтому мой вопрос ниже.

Я работаю со словарем, в котором есть ключи и элементы, как показано ниже. 

Keys:  30 31 32 33 34 35 36 37 39
Items: 21 51 31 64 65 32 29 74 61

У меня также есть некоторые значения, записанные на листе: 

27 28 29 30 31 32 33 34 35 36 37 38 39 40

Моя цель - изменить размер словаря и записать элементы, содержащиеся в нем, в ячейку под ячейкой, соответствующей ключу словаря.

До сих пор я мог записать словарь только в определенное место на листе ws: 

ws.Range("C28").Resize(1, dict.Count).Value2 = dict.Keys
ws.Range("C29").Resize(1, dict.Count).Value2 = dict.Items

Я пробовал следующий код, но это только начало. Конечно, я собираюсь не сюда, но это все, о чем я могу думать. Любая помощь или очки будут очень благодарны. Спасибо. 

Dim key As Variant
Dim cell As Range

With ws
For Each cell In .Range("D10:S10")
    If dict.Exists(cell.Value) Then
        cell.Offset(2, 0).Value = dict.Items
    End If
Next

For Each key In dict
    With .Cells(.Rows.Count, 4).End(xlUp).Offset(1)
        .Value = key
        .Offset(, 2) = dict(key)
    End With
Next

В конце

Пример из результата рабочего листа: введите описание изображения здесь

Обновление кода после комментариев (еще не завершено для конкретной c проблемы, но является подтверждением концепции. Оно находится в разработке с комментариями.) 

Sub TEST()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet2")   ' <- change the sheet name
    Dim oDict As New Scripting.Dictionary
    Dim iRow As Long: iRow = oWS.Cells(oWS.Rows.Count, 10).End(xlUp).Row                                      ' <- iRow and be set dynamically
    Dim oCell As Range
    
    oDict.Add 30, 70
    oDict.Add 31, 71
    oDict.Add 32, 72
    oDict.Add 33, 73
    oDict.Add 34, 74
    oDict.Add 35, 75
    oDict.Add 36, 76
    oDict.Add 37, 77
    oDict.Add 38, 78
    oDict.Add 39, 79
    oDict.Add 40, 80
    oDict.Add 42, 82
    
    With oWS
        
        For Each oCell In .Range("A1:P1")
        
            If oDict.Exists(oCell.Value) Then
                iRow = iRow + 1
                '.Cells(1, iRow).Value = oCell.Value
                .Cells(2, iRow).Value = oDict.Item(oCell.Value)
            End If
        
        Next
        
    End With

End Sub

Ответы [ 3 ]

1 голос
/ 10 июля 2020

Возможно, это слишком упрощает проблему, но если я правильно понимаю ваши требования, это должно сработать 

Sub SetDictValues()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3")
    Dim oDict As New Scripting.Dictionary
    Dim iRow As Long: iRow = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row
    Dim rKeys As Range: Set rKeys = oWS.Range("A2:A" & iRow)
    Dim rUpdateRng As Range
    Dim oCell As Range
    
    oDict.Add 30, 70
    oDict.Add 31, 71
    oDict.Add 32, 72
    oDict.Add 33, 73
    oDict.Add 34, 74
    oDict.Add 35, 75
    oDict.Add 36, 76
    oDict.Add 37, 77
    oDict.Add 38, 78
    oDict.Add 39, 79
    oDict.Add 40, 80
    
    With oWS
        
        For Each oCell In .Range("A1:K1")
        
            If oDict.Exists(oCell.Value) Then
                
                Set rUpdateRng = rKeys.Find(oCell.Value)
                If Not rUpdateRng Is Nothing Then
                    rUpdateRng.Offset(, 2).Value = oDict.Item(oCell.Value)
                End If
            End If
        
        Next
        
    End With
    
End Sub
0 голосов
/ 10 июля 2020

После множества проб и ошибок и отличной помощи от @ Za c я получил ответ на свою проблему:

Окончательный код 

Sub SetDictValues()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet2")
    Dim oDict As New Scripting.Dictionary
    Dim iRow As Long
    Dim rKeys As Range
    Dim rUpdateRng As Range
    Dim oCell As Range
    
    iRow = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row
    Set rKeys = oWS.Range("A1:A" & iRow)
    
    oDict.Add 30, 70
    oDict.Add 31, 71
    oDict.Add 32, 72
    oDict.Add 33, 73
    oDict.Add 34, 74
    oDict.Add 35, 75
    oDict.Add 36, 76
    oDict.Add 37, 77
    oDict.Add 38, 78
    oDict.Add 39, 79
    oDict.Add 40, 80
    oDict.Add 42, 81
    
    With oWS
        
        For Each oCell In .Range("A1:P1")
        
            If oDict.Exists(oCell.Value) Then
                
                Set rUpdateRng = rKeys.Find(oCell.Value)
                If Not rUpdateRng Is Nothing Then
                    rUpdateRng.Offset(1, 0).Value = oDict.Item(oCell.Value)
                End If
            End If
        
        Next
        
    End With

End Sub

Я изменил rUpdateRng.Offset(, 2).Value to rUpdateRng.Offset(1, 0).Value и Set rKeys = oWS.Range("A2:A" & iRow) на Set rKeys = oWS.Range("A1:A" & iRow), чтобы избежать перезаписи значений ключей.

0 голосов
/ 10 июля 2020

Это должно делать то, что вы описываете: 

'...
For Each cell In .Range("D10:S10").Cells
    if dict.Exists(cell.value) Then
        cell.Offset(2, 0).value = dict(cell.Value)
    end if
Next
'...
...