Results 1 to 2 of 2

Thread: VBA create rows based on date range value
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Jun 2017
    Posts
    4
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Post VBA create rows based on date range value

    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 NICKNAME CHECK OUT CHECK IN SOURCE ΣTOTAL PAYOUT ΣNUMBER OF NIGHTS ΣTOTAL REFUNDED
    BL031 12/19/2018 12/14/2018 Booking.com £1 495 5
    BL032 12/19/2018 12/14/2018 Booking.com £1 495 5 £100
    BL031 01/23/2019 01/09/2019 Booking.com £4 060 14

    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

  2. #2
    Board Regular
    Join Date
    Nov 2008
    Location
    Netherlands
    Posts
    3,463
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: VBA create rows based on date range value

    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
    Short Guide to Better VBA - Link: https://www.mrexcel.com/forum/showthread.php?t=712119

    Please use code tags around your code:
    [Code] Your code here... [/Code]




    Engelse lessen, persoonlijk en doelgericht. Dutch tuition tailor-made for you. https://Ennef.nl

    Wearable for people with panic attacks: sidjup https://sidjup.com

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •