I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!

 

TestSuite

Option Explicit

Enum types
    ty_start = 0 'So that we can iterate from ty_start + 1 to ty_end - 1
    ty_boolean
    ty_currency
    ty_date
    ty_decimal
    ty_double
    ty_long
    ty_string
    ty_end  'So that we can iterate from ty_start + 1 to ty_end - 1
End Enum 'types

Enum param_rows
    pr_records = 3
    pr_shuffle
    pr_Boolean = 6
        pr_bTrue
        pr_bFalse
    pr_Currency
        pr_ccyMin
        pr_ccyMax
        pr_ccyAvg
        pr_ccyStDev
    pr_Date
        pr_dtMin
        pr_dtMax
        pr_dtAvg
        pr_dtStDev
    pr_Decimal
        pr_decMin
        pr_decMax
        pr_decAvg
        pr_decStDev
    pr_Double
        pr_dMin
        pr_dMax
        pr_dAvg
        pr_dStDev
    pr_Long
        pr_lMin
        pr_lMax
        pr_lMaxRepeat
    pr_String
        pr_sLength
        pr_sMin
        pr_sMax
        pr_sNextTabRepeat
        pr_sNextTabColumn
        pr_sNextTabItemRepeat
        pr_sNextTabItemColumn
        pr_sNextTabGroupColumn
        pr_sNextTabGroupWeights 'Item group weights start from here and can go down any number
End Enum 'param_rows

Enum param_columns
    pc_Output1 = 1
    pc_Output2
    pc_ItemGroups = 7
    pc_Input1 = 8
    pc_Input2
End Enum 'param_columns

Private Enum xlCI 'Excel Color Index
: xlCIBlack = 1: xlCIWhite: xlCIRed: xlCIBrightGreen: xlCIBlue '1 - 5
: xlCIYellow: xlCIPink: xlCITurquoise: xlCIDarkRed: xlCIGreen '6 - 10
: xlCIDarkBlue: xlCIDarkYellow: xlCIViolet: xlCITeal: xlCIGray25 '11 - 15
: xlCIGray50: xlCIPeriwinkle: xlCIPlum: xlCIIvory: xlCILightTurquoise '16 - 20
: xlCIDarkPurple: xlCICoral: xlCIOceanBlue: xlCIIceBlue: xlCILightBrown '21 - 25
: xlCIMagenta2: xlCIYellow2: xlCICyan2: xlCIDarkPink: xlCIDarkBrown '26 - 30
: xlCIDarkTurquoise: xlCISeaBlue: xlCISkyBlue: xlCILightTurquoise2: xlCILightGreen '31 - 35
: xlCILightYellow: xlCIPaleBlue: xlCIRose: xlCILavender: xlCITan '36 - 40
: xlCILightBlue: xlCIAqua: xlCILime: xlCIGold: xlCILightOrange '41 - 45
: xlCIOrange: xlCIBlueGray: xlCIGray40: xlCIDarkTeal: xlCISeaGreen '46 - 50
: xlCIDarkGreen: xlCIGreenBrown: xlCIBrown: xlCIDarkPink2: xlCIIndigo '51 - 55
: xlCIGray80 '56
End Enum

Sub sbGenerateTestData()
'Randomly generate test data as specified in input area.
'Reverse("moc.LiborPlus.www")
'Change history:
'Version Date        Who   Comment
'0.12    27-Mar-2013 Bernd Initial version
'0.13    02-Apr-2013 Bernd Some health checks / error messages
Dim bGroupsUpToDate As Boolean
Dim dAvg As Double
Dim dMax As Double
Dim dMin As Double
Dim dStDev As Double
Dim dSumWeights As Double
ReDim dTypeWeight(ty_start + 1 To ty_end - 1) As Double
ReDim sTypeName(ty_start + 1 To ty_end - 1) As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim lCol As Long
Dim lLength As Long
Dim lRecord As Long
Dim lRow As Long
Dim lIdx As Long
Dim lTypeSum As Long
Dim objItem As Object
Dim objGroup As Object
Dim s As String
Dim sErrMsg As String
Dim v As Variant
Dim vThisType As Variant
Dim vType As Variant
Dim vGroup As Variant
Dim ws As Worksheet
Dim wsItem As Worksheet
Dim state As SystemState 'See www.sulprobil.com/html/systemstate.html

Set state = New SystemState
Set ws = Sheets("Data")

With Application.WorksheetFunction

'Clear input
ws.Range("A:A").Offset(, pc_Output1 - 1).ClearContents
ws.Range("A:A").Offset(, pc_Output2 - 1).ClearContents
ws.Range("A:A").Offset(, pc_Output1 - 1).ClearFormats
ws.Range("A:A").Offset(, pc_Output2 - 1).ClearFormats
ws.Range("A:A").Offset(, pc_Output1 - 1).Interior.ColorIndex = xlCIGray25
ws.Range("A:A").Offset(, pc_Output2 - 1).Interior.ColorIndex = xlCIGray25
With ws.Range("A1").Offset(, pc_Output1 - 1)
    .Formula = "Test Input 1"
    .Font.Bold = True
    .Interior.ColorIndex = xlCIBrightGreen
End With
With ws.Range("A1").Offset(, pc_Output2 - 1)
    .Formula = "Test Input 2"
    .Font.Bold = True
    .Interior.ColorIndex = xlCIBrightGreen
End With

sTypeName(ty_boolean) = "Boolean"
sTypeName(ty_currency) = "Currency"
sTypeName(ty_date) = "Date"
sTypeName(ty_decimal) = "Decimal"
sTypeName(ty_double) = "Double"
sTypeName(ty_long) = "Long"
sTypeName(ty_string) = "String"

For lCol = pc_Input1 To pc_Input2
    lRecord = ws.Cells(pr_records, lCol)
    If lRecord <= 0 Then Exit For
    ws.Cells(2, lCol - pc_Input1 + pc_Output1).Resize(lRecord).Interior.ColorIndex = xlCILightGreen
    ReDim vInput(1 To lRecord) As Variant
    lIdx = 1
    dTypeWeight(ty_boolean) = ws.Cells(pr_Boolean, lCol)
    dTypeWeight(ty_currency) = ws.Cells(pr_Currency, lCol)
    dTypeWeight(ty_date) = ws.Cells(pr_Date, lCol)
    dTypeWeight(ty_decimal) = ws.Cells(pr_Decimal, lCol)
    dTypeWeight(ty_double) = ws.Cells(pr_Double, lCol)
    dTypeWeight(ty_long) = ws.Cells(pr_Long, lCol)
    dTypeWeight(ty_string) = ws.Cells(pr_String, lCol)
    dSumWeights = 0#
    sErrMsg = ""
    For i = LBound(dTypeWeight) To UBound(dTypeWeight)
        If dTypeWeight(i) < 0 Then sErrMsg = sErrMsg & _
            "Weight for data type " & sTypeName(i) & " must be greater equal zero!" & vbCrLf
        dSumWeights = dSumWeights + dTypeWeight(i)
    Next i
    If dSumWeights <= 0 Then sErrMsg = sErrMsg & _
        "Sum of weights for data types (Boolean, ..., String) must be greater zero!" & vbCrLf
       
    If Len(sErrMsg) > 0 Then
        Call MsgBox(sErrMsg & vbCrLf, vbOKOnly, "Error")
        Exit Sub
    End If
    For i = LBound(dTypeWeight) To UBound(dTypeWeight)
        dTypeWeight(i) = dTypeWeight(i) / dSumWeights * lRecord
    Next i
    'Decide how many records to generate for each data type
    vType = sbLRM("A", 0, dTypeWeight)
   
    For i = LBound(vType, 1) To UBound(vType, 1)
        If vType(i, 1) > 0 Then
            Select Case i
            Case ty_boolean
                ReDim dThisTypeWeight(1 To 2) As Double
                If Abs(ws.Cells(pr_bTrue, lCol) + ws.Cells(pr_bFalse, lCol)) < 0.0000000000001 Then
                    'No weights means equal weights
                    dThisTypeWeight(1) = vType(i, 1) / 2
                    dThisTypeWeight(2) = dThisTypeWeight(1)
                Else
                    dThisTypeWeight(1) = ws.Cells(pr_bTrue, lCol) / _
                                        (ws.Cells(pr_bTrue, lCol) + _
                                        ws.Cells(pr_bFalse, lCol)) * _
                                        vType(i, 1)
                    dThisTypeWeight(2) = ws.Cells(pr_bFalse, lCol) / _
                                        (ws.Cells(pr_bFalse, lCol) + _
                                        ws.Cells(pr_bTrue, lCol)) * _
                                        vType(i, 1)
                End If
                vThisType = sbLRM("A", 0, dThisTypeWeight)
                For j = 1 To vThisType(1, 1)
                    vInput(lIdx) = True
                    lIdx = lIdx + 1
                Next j
                For j = 1 To vThisType(2, 1)
                    vInput(lIdx) = False
                    lIdx = lIdx + 1
                Next j
            Case ty_currency
                If IsEmpty(ws.Cells(pr_ccyAvg, lCol)) Or IsEmpty(ws.Cells(pr_ccyStDev, lCol)) Then
                    'Work with Min and Max
                    dMin = ws.Cells(pr_ccyMin, lCol)
                    dMax = ws.Cells(pr_ccyMax, lCol)
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = CCur(dMin + Rnd() * (dMax - dMin))
                        lIdx = lIdx + 1
                    Next j
                Else
                    'Work with Avg and StDev
                    ReDim dThisDouble(1 To vType(i, 1)) As Double
                    For j = 1 To vType(i, 1)
                        dThisDouble(j) = Rnd()
                    Next j
                    dAvg = .Average(dThisDouble)
                    dStDev = .StDevP(dThisDouble)
                    If dStDev < 0.0000000000001 Then
                        If vType(i, 1) = 1 Then
                            vInput(lIdx) = CCur(dAvg)
                            lIdx = lIdx + 1
                        Else
                            Call MsgBox("StDev of data type " & sTypeName(ty_currency) & _
                                " must not be zero!", vbOKOnly, "Error!")
                            Exit Sub
                        End If
                    End If
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = CCur(ws.Cells(pr_ccyAvg, lCol) + _
                                        (dThisDouble(j) - dAvg) * _
                                        ws.Cells(pr_ccyStDev, lCol) / dStDev)
                        lIdx = lIdx + 1
                    Next j
                End If
            Case ty_date
                If IsEmpty(ws.Cells(pr_dtAvg, lCol)) Or IsEmpty(ws.Cells(pr_dtStDev, lCol)) Then
                    'Work with Min and Max
                    dMin = ws.Cells(pr_dtMin, lCol)
                    dMax = ws.Cells(pr_dtMax, lCol)
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = CDate(dMin + Rnd() * (dMax - dMin))
                        lIdx = lIdx + 1
                    Next j
                Else
                    'Work with Avg and StDev
                    ReDim dThisDouble(1 To vType(i, 1)) As Double
                    For j = 1 To vType(i, 1)
                        dThisDouble(j) = Rnd()
                    Next j
                    dAvg = .Average(dThisDouble)
                    dStDev = .StDevP(dThisDouble)
                    If dStDev < 0.0000000000001 Then
                        If vType(i, 1) = 1 Then
                            vInput(lIdx) = CDate(dAvg)
                            lIdx = lIdx + 1
                        Else
                            Call MsgBox("StDev of data type " & sTypeName(ty_date) & _
                                " must not be zero!", vbOKOnly, "Error!")
                            Exit Sub
                        End If
                    End If
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = CDate(ws.Cells(pr_dtAvg, lCol) + _
                                        (dThisDouble(j) - dAvg) * _
                                        ws.Cells(pr_dtStDev, lCol) / dStDev)
                        lIdx = lIdx + 1
                    Next j
                End If
            Case ty_decimal
                If IsEmpty(ws.Cells(pr_decAvg, lCol)) Or IsEmpty(ws.Cells(pr_decStDev, lCol)) Then
                    'Work with Min and Max
                    dMin = ws.Cells(pr_decMin, lCol)
                    dMax = ws.Cells(pr_decMax, lCol)
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = CDec(dMin + Rnd() * (dMax - dMin))
                        lIdx = lIdx + 1
                    Next j
                Else
                    'Work with Avg and StDev
                    ReDim dThisDouble(1 To vType(i, 1)) As Double
                    For j = 1 To vType(i, 1)
                        dThisDouble(j) = Rnd()
                    Next j
                    dAvg = .Average(dThisDouble)
                    dStDev = .StDevP(dThisDouble)
                    If dStDev < 0.0000000000001 Then
                        If vType(i, 1) = 1 Then
                            vInput(lIdx) = CDec(dAvg)
                            lIdx = lIdx + 1
                        Else
                            Call MsgBox("StDev of data type " & sTypeName(ty_decimal) & _
                                " must not be zero!", vbOKOnly, "Error!")
                            Exit Sub
                        End If
                    End If
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = CDec(ws.Cells(pr_decAvg, lCol) + _
                                        (dThisDouble(j) - dAvg) * _
                                        ws.Cells(pr_decStDev, lCol) / dStDev)
                        lIdx = lIdx + 1
                    Next j
                End If
            Case ty_double
                If IsEmpty(ws.Cells(pr_dAvg, lCol)) Or IsEmpty(ws.Cells(pr_dStDev, lCol)) Then
                    'Work with Min and Max
                    dMin = ws.Cells(pr_dMin, lCol)
                    dMax = ws.Cells(pr_dMax, lCol)
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = CDbl(dMin + Rnd() * (dMax - dMin))
                        lIdx = lIdx + 1
                    Next j
                Else
                    'Work with Avg and StDev
                    ReDim dThisDouble(1 To vType(i, 1)) As Double
                    For j = 1 To vType(i, 1)
                        dThisDouble(j) = Rnd()
                    Next j
                    dAvg = .Average(dThisDouble)
                    dStDev = .StDevP(dThisDouble)
                    If dStDev < 0.0000000000001 Then
                        If vType(i, 1) = 1 Then
                            vInput(lIdx) = CDbl(dAvg)
                            lIdx = lIdx + 1
                        Else
                            Call MsgBox("StDev of data type " & sTypeName(ty_double) & _
                                " must not be zero!", vbOKOnly, "Error!")
                            Exit Sub
                        End If
                    End If
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = CDbl(ws.Cells(pr_dAvg, lCol) + _
                                        (dThisDouble(j) - dAvg) * _
                                        ws.Cells(pr_dStDev, lCol) / dStDev)
                        lIdx = lIdx + 1
                    Next j
                End If
            Case ty_long
                If IsEmpty(ws.Cells(pr_lMaxRepeat, lCol)) Then
                    'Work with arbitrary repetitions
                    dMin = ws.Cells(pr_lMin, lCol)
                    dMax = ws.Cells(pr_lMax, lCol)
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = CLng(dMin + Rnd() * (dMax - dMin + 1))
                        lIdx = lIdx + 1
                    Next j
                Else
                    If (ws.Cells(pr_lMax, lCol) - ws.Cells(pr_lMin, lCol) + 1) * _
                        ws.Cells(pr_lMaxRepeat, lCol) < vType(i, 1) Then
                        Call MsgBox("Not enough random numbers for data type " & sTypeName(ty_long) & _
                            "!", vbOKOnly, "Error!")
                        Exit Sub
                    End If
                    v = sbRandInt(ws.Cells(pr_lMin, lCol), ws.Cells(pr_lMax, lCol), _
                        vType(i, 1), ws.Cells(pr_lMaxRepeat, lCol))
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = v(j, 1)
                        lIdx = lIdx + 1
                    Next j
                End If
            Case ty_string
                If Not IsEmpty(ws.Cells(pr_sLength, lCol)) Then
                    'Simple string
                    lLength = ws.Cells(pr_sLength, lCol)
                    If lLength <= 0 Then lLength = 1
                    dMin = Asc(ws.Cells(pr_sMin, lCol))
                    dMax = Asc(ws.Cells(pr_sMax, lCol))
                    For j = 1 To vType(i, 1)
                        s = ""
                        For k = 1 To lLength
                            s = s & Chr(dMin + Rnd() * (dMax - dMin))
                        Next k
                        vInput(lIdx) = s
                        lIdx = lIdx + 1
                    Next j
                ElseIf Not IsEmpty(ws.Cells(pr_sNextTabRepeat, lCol)) Then
                    'Simple items from next tab
                    Set wsItem = Sheets(2)
                    If (wsItem.Cells(1, ws.Cells(pr_sNextTabColumn, lCol)).End(xlDown).Row - 1) * _
                        ws.Cells(pr_sNextTabRepeat, lCol) < vType(i, 1) Then
                        Call MsgBox("Not enough random numbers for data type " & sTypeName(ty_string) & _
                            "!", vbOKOnly, "Error!")
                        Exit Sub
                    End If
                    v = sbRandInt(2, wsItem.Cells(1, ws.Cells(pr_sNextTabColumn, lCol)).End(xlDown).Row, _
                        vType(i, 1), ws.Cells(pr_sNextTabRepeat, lCol))
                    For j = 1 To vType(i, 1)
                        vInput(lIdx) = wsItem.Cells(1, ws.Cells(pr_sNextTabColumn, lCol))(v(j, 1))
                        lIdx = lIdx + 1
                    Next j
                Else
                    'Items from weighted groups from next tab
                    Set wsItem = Sheets(2)
                    Set objGroup = CreateObject("Scripting.Dictionary")
                    j = 2
                    Do While Not IsEmpty(wsItem.Cells(j, ws.Cells(pr_sNextTabGroupColumn, lCol)))
                        objGroup.Item(wsItem.Cells(j, ws.Cells(pr_sNextTabGroupColumn, lCol)).Value) = _
                            objGroup.Item(wsItem.Cells(j, ws.Cells(pr_sNextTabGroupColumn, lCol)).Value) + 1
                        j = j + 1
                    Loop
                    'Are the item groups still identical to the ones in the param list?
                    bGroupsUpToDate = True
                    j = 0
                    Do While Not IsEmpty(ws.Cells(pr_sNextTabGroupWeights + j, pc_ItemGroups))
                        If objGroup.Item(ws.Cells(pr_sNextTabGroupWeights + j, pc_ItemGroups).Value) > 0 Then
                            objGroup.Item(ws.Cells(pr_sNextTabGroupWeights + j, pc_ItemGroups).Value) = 0
                        Else
                            Set objGroup = Nothing
                            Set objGroup = CreateObject("Scripting.Dictionary")
                            j = 2
                            Do While Not IsEmpty(wsItem.Cells(j, ws.Cells(pr_sNextTabGroupColumn, lCol)))
                                objGroup.Item(wsItem.Cells(j, ws.Cells(pr_sNextTabGroupColumn, lCol)).Value) = _
                                    objGroup.Item(wsItem.Cells(j, ws.Cells(pr_sNextTabGroupColumn, lCol)).Value) + 1
                                j = j + 1
                            Loop
                            bGroupsUpToDate = False
                            Exit Do
                        End If
                        j = j + 1
                    Loop
                    If j <> objGroup.Count Then bGroupsUpToDate = False
                    If Not bGroupsUpToDate Then
                        Range(ws.Cells(pr_sNextTabGroupWeights, pc_ItemGroups), ws.Cells(pr_sNextTabGroupWeights, pc_ItemGroups).End(xlDown)).ClearContents
                        ws.Cells(pr_sNextTabGroupWeights, pc_ItemGroups).Resize(objGroup.Count).FormulaArray = .Transpose(objGroup.keys)
                        If vbCancel = MsgBox("Item groups from next tab are not up to date!" & vbCrLf & _
                            vbCrLf & "OK to continue anyway" & _
                            vbCrLf & "Cancel to stop", vbOKCancel, "Warning") Then
                            Exit Sub
                        End If
                    End If
                    dSumWeights = 0#
                    j = 0
                    Do While Not IsEmpty(ws.Cells(pr_sNextTabGroupWeights + j, pc_ItemGroups))
                        dSumWeights = dSumWeights + ws.Cells(pr_sNextTabGroupWeights + j, lCol)
                        j = j + 1
                    Loop
                    ReDim dGroupWeights(1 To j) As Double
                    For j = LBound(dGroupWeights) To UBound(dGroupWeights)
                        dGroupWeights(j) = ws.Cells(pr_sNextTabGroupWeights + j - 1, lCol) / dSumWeights * vType(i, 1)
                    Next j
                    'Decide how many records to generate for each item group
                    vGroup = sbLRM("A", 0, dGroupWeights)
                    For j = LBound(vGroup, 1) To UBound(vGroup, 1)
                        If vGroup(j, 1) > 0 Then
                            Set wsItem = Sheets(2)
                            Set objItem = CreateObject("Scripting.Dictionary")
                            lRow = 2
                            Do While Not IsEmpty(wsItem.Cells(lRow, ws.Cells(pr_sNextTabGroupColumn, lCol)))
                                If wsItem.Cells(lRow, ws.Cells(pr_sNextTabGroupColumn, lCol)).Value = objGroup.keys()(j - 1) Then
                                    objItem.Item(wsItem.Cells(lRow, ws.Cells(pr_sNextTabItemColumn, lCol)).Value) = _
                                        objItem.Item(wsItem.Cells(lRow, ws.Cells(pr_sNextTabItemColumn, lCol)).Value) + 1
                                End If
                                lRow = lRow + 1
                            Loop
                            If objItem.Count * ws.Cells(pr_sNextTabItemRepeat, lCol) < vGroup(j, 1) Then
                                Call MsgBox("Not enough random numbers for data type string, item group " & _
                                    ws.Cells(pr_sNextTabGroupWeights + j, pc_ItemGroups).Value & _
                                    "!", vbOKOnly, "Error!")
                                Exit Sub
                            End If
                            v = sbRandInt(1, objItem.Count, vGroup(j, 1), ws.Cells(pr_sNextTabItemRepeat, lCol))
                            For k = 1 To vGroup(j, 1)
                                vInput(lIdx) = objItem.keys()(v(k, 1) - 1)
                                lIdx = lIdx + 1
                            Next k
                            Set objItem = Nothing
                        End If
                    Next j
                    Set objGroup = Nothing
                End If
            End Select
        End If
    Next i
    'Now shuffle the result vector into random order if specified
    If ws.Cells(pr_shuffle, lCol) Then
        lRow = 2
        For Each v In VBUniqRandInt(lRecord, lRecord)
            ws.Cells(lRow, lCol - pc_Input1 + pc_Output1) = vInput(v)
            lRow = lRow + 1
        Next v
    Else
        For lRow = 2 To lRecord + 1
            ws.Cells(lRow, lCol - pc_Input1 + pc_Output1) = vInput(lRow - 1)
        Next lRow
    End If
Next lCol
ws.Calculate
End With

End Sub

Sulprobil   Get it done   Contact   Disclaimer   Download