VBA create rows based on date range value

Mathexcel

New Member
Joined
Jun 22, 2017
Messages
36
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:

LISTING'S NICKNAMECHECK OUTCHECK INSOURCEΣTOTAL PAYOUTΣNUMBER OF NIGHTSΣTOTAL REFUNDED
BL03112/19/201812/14/2018Booking.com£1 4955
BL03212/19/201812/14/2018Booking.com£1 4955 £100
BL03101/23/201901/09/2019Booking.com£4 06014

<colgroup><col><col span="2"><col><col><col><col></colgroup><tbody>
</tbody>

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
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
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.


Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,202
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top