將列轉置為值相似的行

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

希望對您有幫助。