Перенести столбец в строки, где значения схожи

Question

У меня есть столбец, где данные складываются.В этих данных есть значения, которые похожи друг на друга. Мне интересно, есть ли способ транспонировать на основе их сходства.

Вот пример того, как выглядят данные.

    +---+------------------+
    |   |       A          |  
    +---+------------------+
    | 1 | st.south.23.001  |  
    +---+------------------+
    | 2 | st.south.23.002  |   
    +---+------------------+
    | 3 | st.south.23.003  |  
    +---+------------------+
    | 4 | nt.north.35.001  |
    +---+------------------+
    | 5 | nt.north.35.003  |  
    +---+------------------+
    | 6 | nt.north.35.004  |
    +---+------------------+
    | 7 | st.south.29.001  |  
    +---+------------------+
    | 8 | st.south.29.002  |
    +---+------------------+
    | 9 | st.south.29.003  |  
    +---+------------------+
    | 10| st.south.29.005  |
    +---+------------------+

Вот как будет выглядеть желаемый результат.Я не смог вместить все записи qq.

    +---+------------------+-----------------+------------------+
    |   |        A         |        B        |         C        |
    +---+------------------+-----------------+------------------+
    | 1 | st.south.23.001  | st.south.23.002 |  st.south.23.003 | 
    +---+------------------+-----------------+------------------+
    | 2 | nt.north.35.001  | nt.north.35.003 | nt.north.35.004  |
    +---+------------------+-----------------+------------------+
    | 3 | st.south.29.001  | st.south.29.002 | st.south.29.003  |
    +---+------------------+-----------------+------------------+

Это текст между st, nt и 00 ~ s, который является ключом к этому, но я совсем не уверен, как это сделать.

Могу ли я попросить кого-то помочь с этим, пожалуйста?

Answer 1

Это будет работать для вашего набора данных.Это довольно простая реализация, поэтому вам нужно будет настроить то, что вам нужно.

Вам нужно будет создать новый рабочий лист с именем Output , чтобы он работал.

Вам также нужно добавить ссылку в вашем проекте VBA на Microsoft Scripting Runtime , чтобы заставить его работать (здесь мы надеемся, что вы не на Mac).

Просто выберите диапазон данных и смотрите.

Public Sub DoTranspose()
    Dim objValues As Scripting.Dictionary, objSrcCells As Range, objCell As Range
    Dim strKey As String, strValue As String, arrValues() As String, varKey As Variant
    Dim lngWriteRow As Long, lngWriteCol As Long, i As Long, objDestSheet As Worksheet

    Set objValues = New Scripting.Dictionary

    ' Use a new sheet called "Output" for the results.
    Set objDestSheet = Sheets("Output")

    ' Simply use the selected set of cells as the data for the transposition.
    Set objSrcCells = Selection

    For Each objCell In objSrcCells
        strValue = objCell.Value
        strKey = UCase(Left(strValue, Len(strValue) - 3))

        If Not objValues.Exists(strKey) Then
            ' The key doesn't exist, therefore, add it and add the first value.
            ReDim arrValues(0)
            arrValues(0) = strValue

            objValues.Add strKey, arrValues
        Else
            ' The key exists, append to the values array.
            arrValues = objValues.Item(strKey)

            ReDim Preserve arrValues(UBound(arrValues) + 1)
            arrValues(UBound(arrValues)) = strValue

            objValues.Item(strKey) = arrValues
        End If
    Next

    lngWriteCol = 0

    objDestSheet.Cells.Clear

    ' Write the results of the dictionary out to the destination sheet.
    For Each varKey In objValues.Keys
        lngWriteRow = 0
        lngWriteCol = lngWriteCol + 1

        arrValues = objValues.Item(varKey)

        For i = 0 To UBound(arrValues)
            lngWriteRow = lngWriteRow + 1
            objDestSheet.Cells(lngWriteRow, lngWriteCol) = arrValues(i)
        Next            
    Next

    objDestSheet.Columns.AutoFit
End Sub

Надеюсь, это поможет вам.