数据帧交替阵列

Question

我目前有一个excel文件，其中包含以下信息：

Company Initial     Purchase Number
ABCD            A123456789
ABCD            B123456789
BCDE            C123456789
BCDE            D123456789
BCDE            E123456789
CDEF            F123456789
DEFG            G123456789
DEFG            H123456789
DEFG            I123456789
DEFG            J123456789
DEFG            K123456789

我想把它变成一张表格，这样同一个公司的首字母就不会连续重复了。你知道吗

Company Initial     Purchase Number
DEFG            K123456789
ABCD            A123456789
DEFG            G123456789
ABCD            B123456789
DEFG            J123456789
BCDE            C123456789
DEFG            I123456789
BCDE            D123456789
DEFG            H123456789
BCDE            E123456789
CDEF            F123456789

我目前正在熊猫和VBA中尝试这个方法，但似乎无法找到一个可行的解决方案。我也对其他Python库开放。你知道吗

谢谢。你知道吗

Answer 1

它变得非常笨拙，但在有限的测试工作。可以试试看它是否能经受长期的测试

    Option Explicit
    Sub arrangeArray()
    Dim Arr As Variant, Rslt As Variant, Dict As Dictionary
    Dim MxCnt As Long, i As Long, j As Long, MxKey As String, Rw As Long
    Dim Ky As String, PosInArr As Long, ArrLen As Long, RwCnt As Long
    Dim temp1 As Variant, temp2 As Variant
    Set Dict = New Dictionary
    Arr = Range("A1:B12").Value
    ReDim Rslt(1 To UBound(Arr, 1), 1 To 2)
    ArrLen = UBound(Arr, 1)

     MxKey = ""
     MxCnt = 0
        'Company names taken as keys in a dictionary, values are incremented to number of occurrences
        For i = 1 To ArrLen
        Ky = Arr(i, 1)
            If Dict.Exists(Ky) Then
            Dict(Ky) = Dict(Ky) + 1
            Else
            Dict.Add Ky, 1
            End If

            If MxCnt < Dict(Ky) Then
            MxKey = Ky
            MxCnt = Dict(Ky)
            End If
        Next


        If ArrLen - MxCnt < MxCnt - 1 Then
        MsgBox " it is not possible to Arrange Array Since Total remaining Company names other than " & MxKey & " (occurs " & MxCnt & " times ) is only " & ArrLen - MxCnt & " less than " & MxCnt - 1
        Exit Sub
        End If

        'Dictionary taken to array Arr2 for bubble sort
        i = Dict.Count
        Dim arr2 As Variant
        ReDim arr2(1 To i, 1 To 2)
        For i = 1 To Dict.Count
            arr2(i, 1) = Dict.Keys(i - 1)
            arr2(i, 2) = Dict.Items(i - 1)
        Next i

        'Bubble sort Arr2
        For i = 1 To UBound(arr2, 1) - 1
            For j = i + 1 To UBound(arr2, 1)
                If arr2(i, 2) < arr2(j, 2) Then
                    temp1 = arr2(j, 1)
                    temp2 = arr2(j, 2)
                    arr2(j, 1) = arr2(i, 1)
                    arr2(j, 2) = arr2(i, 2)
                    arr2(i, 1) = temp1
                    arr2(i, 2) = temp2
                End If
            Next j
        Next i

        'First available position of the key in original array Arr
        For i = 1 To Dict.Count
        Ky = arr2(i, 1)
        arr2(i, 2) = 0
            For j = 1 To ArrLen
                If Arr(j, 1) = Ky Then
                arr2(i, 2) = j   'First available position of the key in Arr
                Exit For
                End If
            Next
        Next i

'Create result array as populating it each company names as long available in original array
    Rw = 1
    Do
        RwCnt = 0
        For i = 1 To Dict.Count
        Ky = arr2(i, 1)
        PosInArr = arr2(i, 2)
            If PosInArr > 0 Then
            Rslt(Rw, 1) = Ky
            Rslt(Rw, 2) = Arr(PosInArr, 2)
            Rw = Rw + 1
            RwCnt = RwCnt + 1
            arr2(i, 2) = 0
                'Find Next available Ky in Arr
                    For j = PosInArr + 1 To ArrLen
                        If Arr(j, 1) = Ky Then
                        arr2(i, 2) = j     'next available position of the key in Arr
                        Exit For
                        End If
                     Next j

            If Rw > ArrLen Then Exit For  
            If RwCnt = 2 Then Exit For   ' exit to next Do loop after two rows
            End If
        Next i
    If Rw > ArrLen Then Exit Do
    Loop

    Range("D1").Resize(UBound(Rslt, 1), 2).Value = Rslt

    End Sub

结果就像

ABCD    A123456789      DEFG    G123456789
ABCD    B123456789      BCDE    C123456789
BCDE    C123456789      DEFG    H123456789
BCDE    D123456789      BCDE    D123456789
BCDE    E123456789      DEFG    I123456789
CDEF    F123456789      BCDE    E123456789
DEFG    G123456789      DEFG    J123456789
DEFG    H123456789      ABCD    A123456789
DEFG    I123456789      DEFG    K123456789
DEFG    J123456789      ABCD    B123456789
DEFG    K123456789      DEFG    K123456789
DEFG    K123456789      CDEF    F123456789

Answer 2

借助内存中的列表框，另一种可能性是：

Sub Reshuffle()
Dim Arr As Variant, FreqArr As Variant, Place As Long, Comp1 As Variant, Comp2 As Variant
Dim rngArr As Range, i As Long, j As Long, k As Long, ListB1 As MSForms.ListBox, ListB2 As MSForms.ListBox

Set ListB1 = CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
Set ListB2 = CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")

 Set rngArr = Range("A2:B12")

    With ListB1
        .Column = Application.Transpose(rngArr)
         ListB2.List = .List
                For i = LBound(.List) To UBound(.List)
                    Arr = Application.Match(Application.Transpose(Application.Index(.List, 0, 1)), Application.Index(.List, 0, 1), 0)
                    FreqArr = Application.Frequency(Arr, Arr)
                        If Application.Max(FreqArr) > (UBound(.List) + 2) / 2 Then MsgBox "not possible"
                            For j = 1 To UBound(.List) + 1
                                Place = Application.Match(Application.Large(FreqArr, j), FreqArr, 0)
                                Comp2 = .List(Place - 1, 0)
                                    If Comp2 <> Comp1 Then Exit For
                            Next j
                                Comp1 = Comp2
                                    With ListB2
                                        For k = LBound(.List, 2) To UBound(.List, 2)
                                            .List(i, k) = ListB1.List(Place - 1, k)
                                        Next k
                                        ListB1.RemoveItem Place - 1
                                    End With
                Next i
      End With
rngArr.Value = ListB2.List 'replaces in same range

Set ListB1 = Nothing
Set ListB2 = Nothing

End Sub

Answer 3

这里没有一个保证的解决方案；如果有10个ABCD和1个DEFG，就无法完成。有鉴于此，有些方法并非最佳，但至少会给它一个公平的机会。
简单来说：

1. 创建列表列表，其中每个子列表仅包含一个公司
2. 根据每个子列表中的条目数对主列表进行排序。最后最少
3. 将第一个条目从第一个列表移到目标列表
4. 将第一个条目从第二个列表移到目标列表
5. 从3号开始重复