Creating many rows with binomial data

[kajO]

Hi All,

I have a file that consists of thousands of rows of beehive data. It is currently set up so that each apiary owner has their own row that includes the number of hives they own and what percentage didn't survive. I need this data to be binomial. For instance, in the first row of the attached image, I would have 8 rows with ones for lost and 54 rows with zeros for alive. I need to find a way to avoid doing this all manually as it would likely take hundreds of hours but I don't have a clue where to start.

 

[sandy666]

another approach

WinterAtRisk	WinterLost	WinterAlive	WinterLOSS	Alive/Lost
62	8	54	12.9%	Alive 0 (54) / Lost 1 (8)
365	90	275	24.7%	Alive 0 (275) / Lost 1 (90)
600	80	520	13.3%	Alive 0 (520) / Lost 1 (80)
1400	70	1330	5.0%	Alive 0 (1330) / Lost 1 (70)
210	21	189	10.0%	Alive 0 (189) / Lost 1 (21)

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Type = Table.TransformColumnTypes(Source,{{"WinterAtRisk", Int64.Type}, {"WinterLost", Int64.Type}, {"WinterAlive", Int64.Type}, {"WinterLOSS", Percentage.Type}}),
    AliveLost = Table.AddColumn(Type, "Alive/Lost", each Text.Format(" Alive #[alive] (#[alivet]) / Lost #[lost] (#[lostt])", [alive = 0, alivet = [WinterAtRisk]-[WinterLost], lost = 1, lostt = [WinterLost]]))
in
    AliveLost

 

[JoeMo]

Noticed that the variables Ars and Ct are redundant. Ars can be removed. Replace the code in post #10 designed to handle overflow with the code below :

Sub WriteBinomials_1()
'Assumptions: this macro will be run with the raw data sheet active
'The raw data w/headers will be in BV1:BY? with no other entries below the raw data in col BV
'Output will be written to a new sheet "Output" in cols A:E starting in A2
'output exceeding BlockCount rows will be redirected to cols G:K, M:Q, ...
Const BlockCount As Long = 1000000  'Number of rows in a block of output - not to exceed rows.count-1
Dim Rall As Range, Vall As Variant
Dim R() As Range, Rin As Range, Vin As Variant, Vout As Variant, dataSht As Worksheet, outputSht As Worksheet
Dim i As Long, m As Long, j As Long, k As Long, First As Long, Last As Long, Ct As Long
Set dataSht = ActiveSheet
Set Rall = dataSht.Range("BV2:BY" & dataSht.Cells(Rows.Count, "BV").End(xlUp).Row)
Vall = Rall.Value
If Val(Vall(1, 1)) > BlockCount Then
    MsgBox "WinterAtRisk values must be <= " & BlockCount
    Exit Sub
End If
For i = 1 To UBound(Vall, 1)
    S = S + Val(Vall(i, 1))
    If S > BlockCount Then
        First = Last + 1
        Last = i - 1
        Ct = Ct + 1
        ReDim Preserve R(1 To Ct)
        Set R(Ct) = dataSht.Range(Rall.Rows(First), Rall.Rows(Last))
        S = Val(Vall(i, 1))
    ElseIf i = UBound(Vall, 1) Then
        First = Last + 1
        Last = i
        Ct = Ct + 1
        ReDim Preserve R(1 To Ct)
        Set R(Ct) = dataSht.Range(Rall.Rows(First), Rall.Rows(Last))
    End If
Next i
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
On Error Resume Next
Sheets("Output").Delete
On Error GoTo 0
Set outputSht = Sheets.Add
outputSht.Name = "Output"
    For i = 1 To Ct
        With outputSht.Range("A:E").Offset(0, (i - 1) * 6).Resize(1, 5)
            .ClearContents
            .Rows(1).Value = Array("Alive/Lost", "WinterAtRisk", "WinterLost", "WinterAlive", "WinterLOSS")
            .EntireColumn.AutoFit
        End With
    Next i
For i = 1 To Ct
    Set Rin = R(i)
    Vin = Rin.Value
    For m = 1 To UBound(Vin, 1)
        ReDim Vout(1 To Vin(m, 1), 1 To UBound(Vin, 2) + 1)
        For j = 1 To UBound(Vout, 1)
            If j <= Vin(m, 2) Then
                Vout(j, 1) = 1
                For k = 2 To 5
                    Vout(j, k) = Vin(m, k - 1)
                Next k
            Else
                Vout(j, 1) = 0
                For k = 2 To 5
                    Vout(j, k) = Vin(m, k - 1)
                Next k
            End If
        Next j
    outputSht.Cells(Rows.Count, 1 + (i - 1) * 6).End(xlUp).Offset(1).Resize(UBound(Vout, 1), 5).Value = Vout
    Erase Vout
    Next m
Next i
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

 

[kajO]

Thanks both of you, this has been incredibly helpful!

 

[JoeMo]

Thanks both of you, this has been incredibly helpful!

You are welcome. Glad we could help and thanks for the reply. I'm curious, have you used the code from post #12 on your "file that consists of thousands of rows of beehive data" with success?

 

[kajO]

You are welcome. Glad we could help and thanks for the reply. I'm curious, have you used the code from post #12 on your "file that consists of thousands of rows of beehive data" with success?

I have and everything seems to be in order

 

[JoeMo]

I have and everything seems to be in order

Thanks for the feedback.