Look Values in column 1 and bring column 2 values

后端 未结 3 1010
[愿得一人]
[愿得一人] 2020-12-11 14:39

my data set looks like

Col A   
A/05702; A/05724; A/05724;A/05724;A/05725;A/05725;
corresponding Col B
1;1;2;3;1;3;

I am trying to get the

3条回答
  •  死守一世寂寞
    2020-12-11 14:57

    You can definitely leverage the Dictionary object from the Microsoft Scripting Runtime library. Add the the reference in your VBE with Tools->References.

    Basically, a dictionary allows you to store values against a unique key. You also want to create a set of unique keys but keep appending to the value for that key as you encounter new rows for that key.

    Here's the code:

    Option Explicit
    
    Sub GenerateSummary()
        Dim wsSource As Worksheet
        Dim rngSource As Range
        Dim rngTarget As Range
        Dim lngRowCounter As Long
        Dim objData As New Dictionary
        Dim strKey As String, strValue As String
    
        'get source data
        Set wsSource = ThisWorkbook.Worksheets("Sheet2")
        Set rngSource = wsSource.Range("A1:B" & wsSource.Range("A1").CurrentRegion.Rows.Count)
    
        'analyse data
        For lngRowCounter = 1 To rngSource.Rows.Count
            'get key/ value pair
            strKey = rngSource.Cells(lngRowCounter, 1).Value
            strValue = rngSource.Cells(lngRowCounter, 2).Value
            'if key exists - add to value; else create new key/ value pair
            If objData.Exists(strKey) Then
                objData(strKey) = objData(strKey) & ", " & strValue
            Else
                objData.Add strKey, strValue
            End If
        Next lngRowCounter
    
        'output dictionary to target range
        'nb dictionary is zero-based index
        Set rngTarget = wsSource.Range("C1")
        For lngRowCounter = 1 To objData.Count
            rngTarget.Cells(lngRowCounter, 1).Value = objData.keys(lngRowCounter - 1)
            rngTarget.Cells(lngRowCounter, 2).Value = objData(objData.keys(lngRowCounter - 1))
        Next lngRowCounter
    
    End Sub
    

    Update

    For clarity, I will post screenshots of the data I entered to test this code. So, on my Sheet2 - which was a totally new and empty of any other data - I've got these entries:

    And then after running the macro, it looks like this:

提交回复
热议问题