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
    Post Thanks / Like
    0 Post(s)
    0 Thread(s)

    Post VBA create rows based on date range value


    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:

    BL031 12/19/2018 12/14/2018 £1 495 5
    BL032 12/19/2018 12/14/2018 £1 495 5 £100
    BL031 01/23/2019 01/09/2019 £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.

  2. #2
    Board Regular
    Join Date
    Nov 2008
    Post Thanks / Like
    0 Post(s)
    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.

    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:

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

    Engelse lessen, persoonlijk en doelgericht. Dutch tuition tailor-made for you.

    Wearable for people with panic attacks: sidjup

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