Question

这个问题是基于我在vba中尝试做的这个难题：https://codegolf.stackexchange.com/questions/166765/fun-with-strings-and-numbers

基本上我们在col A中有字符串，在B列和C列中有数字我们必须生成一个列表，以便：

任何字符串的总数应该与其完全相等输入数据中的相应数字。
不应该在序列中相邻地重复任何字符串字符串应出现在输出列表中。
只要随机选择下一个字符串即可他们没有超越两条规则。每个解决方案应该有一个被选中的非零概率。
如果无法组合，则输出应为0。

我试过了，但我不知道如何解决这个问题，这样就不会破坏规则＃2。任何意见都将不胜感激。

Sub generateList()

Application.ScreenUpdating = False

Dim fI As Long, totTimes As Long, i As Long, j As Long, fO As Long, tryCount As Long
Dim myArr()
Dim randNum As Long

OUT.Range("A1:A" & OUT.Rows.Count).Clear
fO = 1

With DATA
    fI = .Range("A" & .Rows.Count).End(xlUp).Row
    If fI < 2 Then MsgBox "No data!": Exit Sub

    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("B2:B" & fI), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With DATA.Sort
        .SetRange DATA.Range("A1:B" & fI)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    fI = .Range("A" & .Rows.Count).End(xlUp).Row
    If fI < 2 Then MsgBox "No data!": Exit Sub

    totTimes = 0: j = 0
    For i = 2 To fI
        If Trim(.Range("A" & i).Value) <> "" And IsNumeric(.Range("B" & i).Value) Then j = j + 1
    Next i
    If j < 1 Then MsgBox "No valid data present. Make sure column B has numbers and column A some string.": Exit Sub

    ReDim Preserve myArr(1 To j, 1 To 2)
    j = 0
    For i = 2 To fI
        If Trim(.Range("A" & i).Value) <> "" And IsNumeric(.Range("B" & i).Value) Then
            totTimes = totTimes + CLng(.Range("B" & i).Value)
            j = j + 1
            myArr(j, 1) = .Range("A" & i)
            myArr(j, 2) = .Range("B" & i)
        End If
    Next i


    Do While totTimes > 0

        randNum = WorksheetFunction.RandBetween(1, j)

        If myArr(randNum, 2) > 0 Then
            totTimes = totTimes - 1
            OUT.Range("A" & fO) = myArr(randNum, 1)
            myArr(randNum, 2) = myArr(randNum, 2) - 1
            fO = fO + 1
        End If

tryAgain:
    Loop

End With

Application.ScreenUpdating = True
OUT.Activate
MsgBox "Process Completed"

End Sub

Answer 1

我有一个解决方案（不幸的是，这不是基于你的解决方案），它可以在某些时候给出正确的结果。我想我知道为什么它不足，我只是放弃了修复它。

打高尔夫也很可怕，因为它的代码数量相当大，而且在我去的时候，我做出了不同的方法和实施思路的不圣洁的混搭（而且我从来没有正确地清理它......但也许其中一些会激励你进一步发展。

根据规则＃3，我随机选择每个字母。只使用那种方法就是命中和错过所以我转向加权概率，这是代码进一步使用的 - 而且似乎工作得有点好。偶尔会有一个字母对于其中一个元素来说太多，或者会有相邻的相等元素，因此它实际上并不能解决这个难题。

解决此问题的想法：

根据每个字母已被使用的频率调整概率权重。如果您将dbg设置为true，您会看到我实现了一些计算，但从未想过要弄清楚如何实际调整权重。
对于最大元素组
更改rand部分以进行超过1次传递（最好是3次） - 权重按＆＃34;尺寸＆＃34;排序，所以做3（或n）传递应该越来越有利于更大的元素组

可能是第一个和最后一个建议的组合。

以下是代码：

Sub NonRepeatSort(v() As String)
    Dim lElementCount As Long
    Dim lElement As Element ' Largest
    Dim tElement As Long ' Total element count
    Dim tEleGroups As Long ' Number of groups of elements

    Dim tEle As Element
    Dim e As Element
    Dim EleCol As New Collection

    Dim dbg As Boolean
    dbg = False

    Dim s As String, res As String, previousRes As String, inputString As String
    Dim lCounter As Long

    For i = 1 To UBound(v)
        ' Check if element already exists
        On Error Resume Next
            s = ""
            s = EleCol.Item(v(i, 1))
        On Error GoTo 0

        ' If not, create new
        If s = "" Then
            Set tEle = New Element
            With tEle
                .SetName = v(i, 1)
                .SetTotal = CLng(v(i, 2))
            End With

            EleCol.Add Item:=tEle, Key:=tEle.Name
        End If
    Next i

    For Each e In EleCol
        ' Find the largest element
        If e.Total > lElementCount Then
            lElementCount = e.Total
            Set lElement = e
        End If

        ' Count total elements
        tElement = tElement + e.Total

        ' And groups
        tEleGroups = tEleGroups + 1

        ' Generate inputstring
        For k = 1 To e.Total
            inputString = inputString + e.Name
        Next k
    Next e

    ' If the largest element is larger than the total remaining elements, we'll break rule 4
    If lElement.Total - (tElement - lElement.Total) > 1 Then
        Debug.Print "0"
        GoTo EndForSomeReason
    End If

    ' Bubble sort - lowest to highest
    ' Adapted from https://stackoverflow.com/a/3588073/4604845
    Dim tmpE As Element
    For x = 1 To EleCol.Count - 1
        For y = 1 To EleCol.Count
            If EleCol.Item(x).Total > EleCol.Item(y).Total Then
                Set tmpE = EleCol.Item(y)
                EleCol.Remove y
                EleCol.Add tmpE, tmpE.Name, x
            End If
        Next y
    Next x

    ' Weighted probability array
    Dim pArr() As Variant, tmpProb As Double
    ReDim Preserve pArr(1 To 2, 1 To EleCol.Count)
    For u = 1 To UBound(pArr, 2)
        Set pArr(2, u) = EleCol.Item(u)
        tmpProb = tmpProb + pArr(2, u).Freq(tElement)
        pArr(1, u) = tmpProb
    Next u

    ' The meat of it
    Dim r As Long, lBool As Boolean, sLen As Long, o As Double, t As Long

    For j = 1 To tElement
        Do
            ' Reset loop control
            lBool = False

            ' Generate a random number between 1 and 100 _
                to decide which group we pick a letter from
            r = Rand1To100

            For i = 1 To UBound(pArr, 2)
                If r <= pArr(1, i) And Not r > pArr(1, i) Then
                    If dbg Then Debug.Print "Probability match: " & pArr(2, t).Name
                    t = i
                    Exit For
                End If
            Next i

            Set tEle = EleCol.Item(t)

            If dbg Then Debug.Print "Name: " & tEle.Name

            ' If the random group is different from the previous result, proceed
            If tEle.Name <> previousRes Then
                lBool = True
            Else
                If dbg Then Debug.Print "This was also the previous result - skipping"
            End If

            ' If the use-frequency for the random group is lower than _
                how many times it appears in the string, proceed
            If lBool Then
                o = Round((tEle.Used / tElement) * 100, 5)

                If dbg Then Debug.Print "Freq: " & tEle.Freq(tElement)
                If dbg Then Debug.Print "Used: " & tEle.UsedFreqI()
                If dbg Then Debug.Print "res%: " & Round((Len(res) / tElement) * 100, 1)
                If dbg Then Debug.Print "o   : " & o

                ' check use-frequency against modeled frequency
                If o < tEle.Freq(tElement) Then
                    If dbg Then Debug.Print "Proceed with " & tEle.Name
                    lBool = True
                Else
                    lBool = False
                End If
            End If

            If dbg Then Debug.Print "----------"
            lCounter = lCounter + 1
        Loop While (Not lBool And lCounter < 1000)

        tEle.IncrementUsed
        res = res + tEle.Name
        previousRes = tEle.Name
    Next j

    ' Generate results
    Debug.Print "INPUT : " & inputString
    Debug.Print "RESULT: " & res

EndForSomeReason:
End Sub


Function Rand1To100() As Long
    Dim r As Long

    Randomize
    r = ((100 - 1) * Rnd + 1)
    r = Round(r, 0)

    Rand1To100 = r
End Function


Private Sub TestSort()
    Dim v(1 To 4, 1 To 2) As String
    v(1, 1) = "A"
    v(1, 2) = "6"

    v(2, 1) = "B"
    v(2, 2) = "2"

    v(3, 1) = "C"
    v(3, 2) = "2"

    v(4, 1) = "D"
    v(4, 2) = "4"

    Call NonRepeatSort(v)
End Sub

你需要这个课程模块：

' * Class module named Element

Private pName As String
Private pTotal As Long
Private pUsed As Long
Private FrequencyCoefficient As Long ' Obsolete?

' Name
Public Property Get Name() As String
    Name = pName
End Property
Public Property Let SetName(s As String)
    pName = s
End Property

' Total
Public Property Get Total() As Long
    Total = pTotal
End Property
Public Property Let SetTotal(t As Long)
    pTotal = t
End Property

' Used
Public Property Get Used() As Long
    Used = pUsed
End Property
Public Sub IncrementUsed()
    pUsed = pUsed + 1
End Sub

' Freq coefficient
Public Property Get Freq(f As Long) As Double
    ' Where f is the total number of elements
    'Freq = FrequencyCoefficient
    Freq = Round((Me.Total / f) * 100, 5)
End Property

Private Property Let SetFreq(f As Long)
    ' Obsolete?
    ' Where f is the total number of elements
    FrequencyCoefficient = Round((Me.Total / f) * 100)
End Property

' Used freq - internal
Public Property Get UsedFreqI() As Long

    If Me.Used > 0 Then
        UsedFreqI = Round((Me.Used / Me.Total) * 100)
        'Debug.Print "UF: " & UsedFreqI
    Else
        UsedFreqI = 0
    End If
End Property

' Used freq - external
Public Property Get UsedFreqE(f As Long) As Long
    If Me.Used > 0 Then
        UsedFreq = Round((Me.Used / f) * 100)
    Else
        UsedFreq = 0
    End If
End Property

从字符串和数字vba生成列表

1 个答案: