VBA create rows based on date range value

[Mathexcel]

Hi,

I need to transform a raw extract into a new sheet for a pivot source. The raw extract has transactional information + check-in and check-out as shown below:

[TABLE="width: 728"]
<colgroup><col><col span="2"><col><col><col><col></colgroup><tbody>[TR]
[TD]LISTING'S NICKNAME[/TD]
[TD]CHECK OUT[/TD]
[TD]CHECK IN[/TD]
[TD]SOURCE[/TD]
[TD]ΣTOTAL PAYOUT[/TD]
[TD]ΣNUMBER OF NIGHTS[/TD]
[TD]ΣTOTAL REFUNDED[/TD]
[/TR]
[TR]
[TD]BL031[/TD]
[TD]12/19/2018[/TD]
[TD]12/14/2018[/TD]
[TD]Booking.com[/TD]
[TD="align: right"]£1 495[/TD]
[TD="align: right"]5[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]BL032[/TD]
[TD]12/19/2018[/TD]
[TD]12/14/2018[/TD]
[TD]Booking.com[/TD]
[TD="align: right"]£1 495[/TD]
[TD="align: right"]5[/TD]
[TD] £100[/TD]
[/TR]
[TR]
[TD]BL031[/TD]
[TD]01/23/2019[/TD]
[TD="align: right"]01/09/2019[/TD]
[TD]Booking.com[/TD]
[TD="align: right"]£4 060[/TD]
[TD="align: right"]14[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Objective > create a macro that create a new table in a new sheet .


The new table should have 28 rows ( 5 + 5 + 14) with:
(1) an additional colum DATE with the actual date of each stay and;
(2) an new column Average Price = (Total Payout - Total Refunded) / Number of Nights.

I guess I need a For loop but don't have the competency to write this code. I guess it should go like this:
For each row in range, consider that check in date and create a new row until check out date.

Many thanks for your help.
Bless,
Matt

 

[sijpie]

This will do what you ask and puts the results in a sheet, starting from A1. If you want to add the reults to the bottom of an existing list, let me know.

Please check the comments in the macro code. At the top there are two comments on whcih you need to act. One is the name of the input sheet, the other of the output sheet. The code does not do any checking for these sheet names.

Option Explicit


Sub OutputPerDay()
    Dim lRi As Long, lRo As Long, lCi As Long, lCo As Long, i As Long, UB1 As Long, UB2 As Long
    Dim dAvg As Double
    Dim vInp As Variant, vOutp As Variant
    Dim wsInp As Worksheet, wsoutp As Worksheet
    Dim rInp As Range, rOutp As Range
    
    Set wsInp = Sheets("Sheet1")    '>>>> Amend input sheet name as required
    Set wsoutp = Sheets("PivotInput")   '>>>> Amend output sheet name as required
    
    Set rInp = wsInp.Range("A1").EntireColumn.Find("LISTING'S NICKNAME")
    If rInp Is Nothing Then
        MsgBox "Can't find input range heading"
        Exit Sub
    End If
    
    Set rOutp = wsoutp.Range("A1")
    
    ' read the input data into an array for fast processing
    vInp = rInp.CurrentRegion.Value
    'get the number of rows and columns
    UB1 = UBound(vInp, 1)
    UB2 = UBound(vInp, 2)
    
    ' calculate the number of rows for the output by counting the number of days
    For lRi = 2 To UB1      'skip header row
        i = i + vInp(lRi, 6)
    Next lRi
    
    ' create the output array
    ReDim vOutp(1 To i + 1, 1 To UB2 + 2)
    ' set the headers . Assumed that actual day will come as column 2 and avg cost as last column
    vOutp(1, 1) = vInp(1, 1)
    vOutp(1, 2) = "DATE"
    For lCi = 2 To UB2
        vOutp(1, lCi + 1) = vInp(1, lCi)
    Next lCi
    vOutp(1, UB2 + 2) = "AVG RATE"
    
    'Now process the data
    lRo = 2
    For lRi = 2 To UB1
        i = 0
        dAvg = (CC2V(vInp(lRi, 5)) - CC2V(vInp(lRi, 7))) / vInp(lRi, 6)
        For lRo = lRo To lRo + vInp(lRi, 6) - 1
            vOutp(lRo, 1) = vInp(lRi, 1)        'Nickname
            vOutp(lRo, 2) = vInp(lRi, 3) + i    'Date
            i = i + 1
            For lCi = 2 To UB2
                vOutp(lRo, lCi + 1) = vInp(lRi, lCi)
            Next lCi
            vOutp(lRo, UB2 + 2) = dAvg          'average
        Next lRo
    Next lRi
    
    'now output the result araay:
    rOutp.Resize(UBound(vOutp, 1), UB2 + 2).Value = vOutp
    
End Sub




'convert the text currencys to numbers (£1 495 -> 1495)
Function CC2V(sCur As Variant) As Double
    Dim sC As String, sOut As String
    Dim i As Integer
    
    If Len(sCur) Then
    
        For i = 1 To Len(sCur)
            sC = Mid(sCur, i, 1)
            If IsNumeric(sC) Then sOut = sOut & sC
        Next i
        CC2V = CDbl(sOut)
    End If
End Function