Question

例如：我在伦敦有一辆车，60％的情况下可以到牛津，30％到利物浦，10％到加的夫。

我想了解如何编写VBA代码以获得这样的结果，根据之前写的百分比编写目标字符串：

From           To      
London         Cardiff
From           To
London         Liverpool
From           To
London         Liverpool
From           To
London         Oxford
From           To
London         Oxford  
From           To
London         Oxford

Answer 1

我指定了我的概率：

     A          B       C
1  Liverpool  Oxford  Cardiff
2  60         30      10

并使用此代码（评论中的解释）：

'this option makes declaration of variables mandatory, which prevents from mistyping mistakes
Option Explicit
Sub GenerateRoutes()
    'declaration of variables
    Dim probTable As Variant, sheet1 As Worksheet, i As Long, j As Long, howManyRowToGenerate As Long, startRow As Long, endRow As Long
    howManyRowToGenerate = 100
    'always set reference to sheet, also, prevents from many mistakes
    Set sheet1 = Sheets("Sheet1")
    'here you have use range that you have probabilities assigned
    probTable = sheet1.Range("A1:C2").Value2
    'clear specified range
    sheet1.Range("A1:C2").Clear
    sheet1.Cells(1, 1).Value = "From"
    sheet1.Cells(1, 2).Value = "To"
    'using values from given table, generate rows
    startRow = 1
    For i = LBound(probTable, 2) To UBound(probTable, 2)
        endRow = startRow + howManyRowToGenerate * probTable(2, i) / 100 - 1
        For j = startRow To endRow
            sheet1.Cells(j + 1, 1).Value = "London"
            sheet1.Cells(j + 1, 2).Value = probTable(1, i)
        Next
        startRow = j
    Next
End Sub

产生：

     A       B
1  From    To
2  London  Liverpool
3  London  Liverpool
4  London  Liverpool
etc.
62 London  Oxford
etc.

Answer 2

您需要总数量的游乐设施才能对这些百分比做任何事情。因此，请确保将该数字与您的百分比一起存储在某处。让我们假设你的游乐设施数量在单元格Sheet1.Range（“A4”）中，你的三个百分比在上面的单元格中（A1-A3格式为百分比）。我会先让一个Excel公式做一些工作：

Cell B1 =Round($A$1*A1,0)
Cell B2 =Round($A$1*A2,0)
Cell B3 =Round($A$1*A3,0)

在单元格C1-C3中有目的地

您的代码可能看起来像这样：

Sub CreateThisStuff()

Dim x as integer, y as integer, LR as integer
Range("D1:E" & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row).Clear
For x = 1 to 3    
    If range("B" & x).value > 0 and range("C" & x).value <> "" then
    For y = 1 to range("B" & x).value
        LR = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
        If range("D" & x).value = "" then LR = 0
        range("D" & LR + 1).value = "From"
        range("D" & LR + 2).value = "London"
        range("E" & LR + 1).value = "To"
        range("E" & LR + 2).value = range("C" & x).value
    Next y
    End if        
Next x

End sub

希望这可以为您提供如何处理它并让您上路的想法！

此致

Answer 3

听起来你需要一个模拟课程或其他类似但实际上你的音量/音阶要求对VBA不太合理

所以我写了一堂课让你入门，我在EventSpace中打电话

from selenium import webdriver
import time

geckodriver_path = r'.../geckodriver'

driver = webdriver.Firefox(executable_path= geckodriver_path)
time.sleep(3)
driver.get("http://www.stackoverflow.com")

标准模块的一些测试代码

Option Explicit

Private m_dicOutcomes As New Scripting.Dictionary
Private m_dicCumulativeCalc As New Scripting.Dictionary
Private m_dicSimulation As New Scripting.Dictionary

Private m_alCumulProbsOptimized() As Double
Private m_lCount As Long

Private m_lIterations As Long


Public Function ReportResults() As String()

    Dim asReport() As String

    ReDim asReport(0 To m_dicSimulation.Count) As String


    Dim lOutcomeLoop As Long
    For lOutcomeLoop = 0 To m_dicSimulation.Count - 1

        asReport(lOutcomeLoop) = m_dicOutcomes.Keys()(lOutcomeLoop) & vbTab & ": " & (m_dicSimulation.Item(lOutcomeLoop) / m_lIterations)


    Next

    ReportResults = asReport

End Function

Public Function RunSimulation(ByVal lIterations As Long) As Scripting.Dictionary

    m_lIterations = lIterations
    CopyCumulativeProbsToArray

    Dim lLoop As Long
    For lLoop = 1 To lIterations

        Dim lOutCome As Long
        lOutCome = CalcOutcomeFromCumul(Rnd(1))

        m_dicSimulation.Item(lOutCome) = m_dicSimulation.Item(lOutCome) + 1

    Next lLoop

    Set RunSimulation = m_dicSimulation

End Function

Friend Function CalcOutcomeFromCumul(ByVal dblRandom As Double) As Long

    'Dim lLoop2 As Long

    Dim lLoop As Long
    For lLoop = 0 To m_lCount

        If dblRandom < m_alCumulProbsOptimized(lLoop) Then
            CalcOutcomeFromCumul = lLoop
            GoTo SingleExit
        End If

    Next
SingleExit:


End Function

Friend Sub CopyCumulativeProbsToArray()

    m_lCount = m_dicCumulativeCalc.Count - 1

    ReDim m_alCumulProbsOptimized(0 To m_lCount) As Double

    '* copy to an array
    Dim vItems As Variant
    vItems = m_dicCumulativeCalc.Items

    Dim lLoop As Long
    For lLoop = 0 To m_lCount

        m_alCumulProbsOptimized(lLoop) = vItems(lLoop)

    Next

End Sub

Public Sub AddOutcome(ByVal sName, ByVal dblProbavbility As Double)

    If m_dicOutcomes.Exists(sName) Then Err.Raise vbObjectError, , "#Outcome already added!"

    m_dicOutcomes.Add sName, dblProbavbility

End Sub


Public Function CalcCumulative() As Boolean
    Dim vKeyLoop As Variant
    Dim dblCumulative As Double: dblCumulative = 0
    For Each vKeyLoop In m_dicOutcomes
        Dim dblProb As Double
        dblProb = m_dicOutcomes.Item(vKeyLoop)

        dblCumulative = dblCumulative + dblProb
        m_dicCumulativeCalc.Item(vKeyLoop) = dblCumulative
    Next
End Function

Public Function IsFullDefined() As Boolean

    Me.CalcCumulative

    Dim dblFinalCumulative As Double
    dblFinalCumulative = m_dicCumulativeCalc.Items()(m_dicCumulativeCalc.Count - 1)
    If (dblFinalCumulative - 1) < 0.0001 Then
        IsFullDefined = True
    End If

End Function

从那里，您可以使用自己的代码将其连接到工作表中。

如何在已分配概率的VBA中生成指定的字符串？

3 个答案: