asked on

Macro not copy the data correctly

Hi Experts,

I would like to request Experts help to modify the attached macro. The macro has been used to copy data from Booking sheet (Cell 5) to Order sheet based on Start/End Date and Start/End Time condition. The Data are copied evenly across based on number of frequency at cell C11. However, at time the macro copied the data at the wrong cell, enclosed sample of data with different date and frequency:

Title: Title A
Start/End Date: 1-6Jan
Start/End Time:18:00-01:00
Frequency: 4

Title: Title B
Start/End Date: 28-31Jan
Start/End Time:18:00-01:00
Frequency: 2

Hope Experts will help me to make the macro able to handle the sample data as well.

Sub spreaddata()
With Sheets("Booking")
    sdat = CVDate(.[c7])
    edat = CVDate(.[e7])
    stim = CVDate(.[c9])
    If stim < 0.25 Then stim = stim + 1
    etim = CVDate(.[e9])
    If etim < 0.25 Then etim = etim + 1
    ndays = edat - sdat + 1
    If etim < stim Then MsgBox ("Starting time is higher that ending time"): End
    dur = (etim - stim - 0.00001) * ndays
    ns = .[c11]
    Gap = dur / (ns - 1)
End With
dat = sdat
tim = stim
For sh = 1 To ns
    cn = Sheets("Order").Range("2:2").Find(dat).Column
    rn = (tim - 0.25) * 24 * 6 + 3
    Sheets("Order").Cells(rn, cn) = Sheets("Order").Cells(rn, cn) & vbCrLf & Sheets("Booking").[c5]
    If tim + Gap > etim Then
    dat = dat + 1
    tim = tim + Gap - etim + stim
    Else
    tim = tim + Gap
    End If
Next sh
End Sub

Open in new window

OrderList.xlsm

Arno Koster

If you update to this macro it should be a lot closer to your expectations.

The problem was in the calculation of the booking row number and shifting to the next business day

Sub spreaddata()
Dim start_date As Date
Dim start_time As Date
Dim end_date As Date
Dim end_time As Date
Dim number_of_days As Integer
Dim duration As Double
Dim frequency As Integer
Dim gap As Date

With Sheets("Booking")
    '-- initialise
    start_date = CDate(.[c7])
    end_date = CDate(.[e7])
    start_time = CDate(.[c9])
    end_time = CDate(.[e9])
    
    '-- before 6 o'clock = next day
    If start_time < TimeValue("06:00:00") Then start_time = start_time + 1
    If end_time < TimeValue("06:00:00") Then end_time = end_time + 1
    If end_time < start_time Then MsgBox ("Starting time is higher that ending time"): End
       
    '-- calculate time span
    number_of_days = end_date - start_date + 1
    duration = (end_time - start_time - 0.00001) * number_of_days
    frequency = .[c11]
    gap = duration / (frequency - 1)
End With

booking_date = start_date
booking_time = start_time
For booking = 1 To frequency
    '-- locate booking position
    booking_column = Sheets("Order").Range("2:2").Find(booking_date).Column
    booking_row = (booking_time - TimeValue("6:00:00") - WorksheetFunction.Floor(booking_time - TimeValue("6:00:00"), 1)) * 24 * 6 + 3
    '-- add booking to orders
    Sheets("Order").Cells(booking_row, booking_column) = Sheets("Order").Cells(booking_row, booking_column) & vbCrLf & Sheets("Booking").[c5]
    '-- determine next booking
    If booking_time + gap > end_time Then
        booking_date = booking_date + 1
        booking_time = booking_time + gap - end_stime + start_time
    Else
        booking_time = booking_time + gap
    End If
Next booking

End Sub

Open in new window

Cartillo

ASKER

Hi,

Thanks for the code, however the following type data shows error as "Over flow" at "gap = duration / (frequency - 1)"

Title: Title A
Start/End Date: 1-1Jan (single day)
Start/End Time:18:00-01:00
Frequency: 1

How to fix this?

Arno Koster

That will be because of the calculation of the gap :

gap = duration / (frequency - 1) = 6:59:59 / 0

because the gap is not needed when only a single booking is made, you can change

gap = duration / (frequency - 1)

to

if frequency > 1 then gap = duration / (frequency - 1)

Cartillo

ASKER

Hi akoster,

Thanks for the revised code, however when I tested with difference frequency, e.g.

Title: Title D
Start/End Date: 01-06Jan
Start/End Time:18:00pm-01:00am
Frequency: 20

The data were copied outside of start/end time. How to fix this so that the code able to cope even data with “Frequency: 1” or other frequencies.

Arno Koster

That seems to be correct, the original formula apperantly was not designed and/or tested to take into account bookings which span over multiple days
This version should perform better :

Sub spreaddata()
Dim start_date As Date
Dim start_time As Date
Dim end_date As Date
Dim end_time As Date
Dim booking_date As Date
Dim booking_time As Date
Dim duration As Date
Dim gap As Date
Dim number_of_days As Integer
Dim frequency As Integer
Dim booking As Integer
Dim booking_column As Integer
Dim booking_row As Integer

With Sheets("Booking")
    '-- initialise
    start_date = CDate(.[c7])
    end_date = CDate(.[e7])
    start_time = CDate(.[c9])
    end_time = CDate(.[e9])
    
    '-- before 6 o'clock = next day
    If start_time < TimeValue("06:00:00") Then start_time = start_time + 1
    If end_time < TimeValue("06:00:00") Then end_time = end_time + 1
    If end_time < start_time Then MsgBox ("Starting time is higher that ending time"): End
       
    '-- calculate time span
    number_of_days = end_date - start_date + 1
    duration = (end_time - start_time) * number_of_days - 0.00001
    frequency = .[c11]
    If frequency > 1 Then gap = duration / frequency
End With

booking_date = start_date
booking_time = start_time
For booking = 1 To frequency
    '-- locate booking position
    booking_column = Sheets("Order").Range("2:2").Find(booking_date).Column
    booking_row = (booking_time - TimeValue("6:00:00")) * 24 * 6 + 3
    '-- add booking to orders
    Sheets("Order").Cells(booking_row, booking_column) = Sheets("Order").Cells(booking_row, booking_column) & vbCrLf & Sheets("Booking").[c5]
    '-- determine next booking
    booking_time = booking_time + gap
    While booking_time > end_time
        booking_date = booking_date + 1
        booking_time = booking_time - end_time + start_time
    Wend
Next booking

End Sub

Open in new window

Cartillo

ASKER

Hi akoster,

Thanks a lot for adding this function, the data were segregated evenly, but the interval between timing was not fully utilized. I have attached the sample data for better understanding. I have three different titles (Title A, B and C) but booked on the same time and date. As noticed, all data nested at the same time, whereas there is a plenty empty slot that can be used. Hope you will consider this request and make this macro able to disperse the data more evenly and maximized the time gap.
OrderList-V2.xlsm

Arno Koster

That seems to be a different setup than what the macro has been intended to do.
The starting post indicated that the data be segregated evenly, but did not mention that the titles are to be spread out in empty slots as much as possible.

Would it be acceptable to start with generating an evenly dispersed setup and for double bookings take the first available empty slot (looking downwards : at a later time) ?

Cartillo

ASKER

Hi akoster,

I do agree with you, but the problem is you can see the possibilities of deepening the process after seeing the real result. Sorry for this.

Your suggestion to manage the double booking should be able to minimize the data nesting. Hope you consider this.

Arno Koster

No problem, but for future reference it would be best to close this topic and open a related new one to further continue our 'quest'.
This makes it easier for other people to find answers to their problems when they experience similar situations.

I'll have to go home now, so we'll continue tomorrow.

Cartillo

ASKER

Hi akoster,

Thanks for the understanding.

ASKER CERTIFIED SOLUTION

Arno Koster

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Cartillo

ASKER

Hi akoster,

Thanks for the revised code, indeed it's given better options and segregate the data evenly. However, most of the time the data need to be copied at the restricted time/Date . Therefore, the system should be able to allow multiple entries on the same cells once the available Time/Date slots are full. For this I will post a new question, hope you will consider.

Cartillo

ASKER

Hi,

Thanks a lot for the superb code.

Cartillo

ASKER

Hi akoster,

Hope you will consider this request:

https://www.experts-exchange.com/questions/27245925/Allow-multiple-data-entry-in-a-single-cell.html