циклические ячейки для добавления нескольких элементов в ключи словаря

Question

У меня есть список повторяющихся значений в столбце A, которые будут добавлены в качестве ключей в словарь. Затем для каждой строки в столбце A есть другие повторяющиеся значения из столбца 3 до .columns.count. Мне нужно добавить их в словарь как несколько элементов каждого ключа. В конце у меня должно быть два столбца: в первом перечислены все ключи, а во втором - все элементы каждого ключа. Вот мой предварительный. Не могли бы вы узнать, как это исправить?

    Sheets("Sheet3").Select
    With Sheets("Sheet3")
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
    LR = .Range("A" & Sheets("Competitor").Rows.Count).End(xlUp).row


    For thisRow = 2 To LR
     For thiscol = 2 To lc
    'Debug.Print dict.Keys(0)
      If Not dict.Exists(.Cells(thisRow, 1).Value2) And .Cells(thisRow, thiscol).Value2 <> "" Then
      dict.Add .Cells(thisRow, 1).Value2, (.Cells(thisRow, thiscol).Value2)
      Else

      If dict.Exists(.Cells(thisRow, 1).Value2) And .Cells(thisRow, thiscol).Value2 <> "" Then
        dict.Item(.Cells(thisRow, 1).Value2) = .Cells(thisRow, thiscol).Value2
End If
End If
        Next thiscol
        Next thisRow

excel vba dictionary

0

user3818099 13 Мар 2018 в 14:31

Answer 1

Это использует Словарь словарей для возврата уникальных элементов для уникальных ключей

Вариант Явный

Sub main()
    Dim iKey As Long
    Dim valsDict As Scripting.Dictionary
    Set valsDict = CreateObject("Scripting.Dictionary")

    Dim cell As Range, cell2 As Range
    With ActiveWorkbook.Sheets("Competitor") ' change "Competitor" to you actual source sheet name
        For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
            If Not valsDict.Exists(cell.value) Then valsDict.Add cell.value, New Scripting.Dictionary
            For Each cell2 In .Range(cell.Offset(, 1), .Cells(cell.Row, .Columns.Count).End(xlToLeft))
                valsDict(cell.value)(cell2.value) = cell2.value
            Next
        Next

        With .Range("AA1") ' change "AA1" with the cell address you want to start writing down data from
            For iKey = 0 To valsDict.Count - 1
                .Offset(iKey).value = valsDict.Keys(iKey)
                .Offset(iKey, 1).Resize(, valsDict.Items(iKey).Count) = valsDict.Items(iKey).Items
            Next
        End With
    End With
End Sub

0

DisplayName 13 Мар 2018 в 13:15

Answer 2

Вы упомянули, что хотите, чтобы результирующий список состоял из двух столбцов. Следующий код создаст уникальный список значений из столбца A вместе с соответствующими значениями. Уникальные значения будут перечислены в одном столбце, а соответствующие значения будут объединены в следующем столбце. Обратите внимание, что я предположил, что Sheet1 содержит данные, а результаты должны быть помещены в Sheet2.

Option Explicit

Sub CreateUniqueList()

    Dim oDic As Object
    Dim aResults() As Variant
    Dim arrColIndex As Long
    Dim LastRow As Long
    Dim LastCol As Long
    Dim thisRow As Long
    Dim thisCol As Long

    Set oDic = CreateObject("Scripting.Dictionary")
    oDic.CompareMode = 1 'case-insensitive

    With ActiveWorkbook.Worksheets("Sheet1")
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ReDim aResults(1 To 2, 1 To LastRow)
        arrColIndex = 0
        For thisRow = 2 To LastRow
            If Len(.Cells(thisRow, "A").Value) > 0 Then
                If Not oDic.Exists(.Cells(thisRow, "A").Value) Then
                    arrColIndex = arrColIndex + 1
                    aResults(1, arrColIndex) = .Cells(thisRow, "A").Value
                    For thisCol = 2 To LastCol
                        aResults(2, arrColIndex) = aResults(2, arrColIndex) & ", " & .Cells(thisRow, thisCol).Value
                    Next thisCol
                    aResults(2, arrColIndex) = Mid(aResults(2, arrColIndex), 3)
                    oDic.Add .Cells(thisRow, "A").Value, arrColIndex
                Else
                    For thisCol = 2 To LastCol
                        aResults(2, oDic(.Cells(thisRow, "A").Value)) = aResults(2, oDic(.Cells(thisRow, "A").Value)) & ", " & .Cells(thisRow, thisCol).Value
                    Next thisCol
                End If
            End If
        Next thisRow
    End With

    If arrColIndex > 0 Then
        ReDim Preserve aResults(1 To 2, 1 To arrColIndex)
        With ActiveWorkbook.Worksheets("Sheet2")
            With .Range("A1")
                .CurrentRegion.ClearContents
                .Resize(UBound(aResults, 2), 2).Value = Application.Transpose(aResults)
            End With
            .Activate
        End With
    Else
        MsgBox "No items found!", vbExclamation
    End If

    Set oDic = Nothing

End Sub

Данные

Header1 Header2 Header3 Header4
x   1   2   3
y   4   5   6
z   7   8   9

x   10  20  30
y   40  50  60
z   70  80  90

Результаты

x   1, 2, 3, 10, 20, 30
y   4, 5, 6, 40, 50, 60
z   7, 8, 9, 70, 80, 90

Надеюсь это поможет!

0

Domenic 14 Мар 2018 в 00:11

циклические ячейки для добавления нескольких элементов в ключи словаря

2 ответа

Похожие вопросы

Новые вопросы

excel