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

Answer 1

这使用词典词典来返回uniqe键的唯一项目

选项明确

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

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

希望这有帮助！

循环单元格将多个项目添加到字典键

2 个答案: