How to mend the excel macro that helps me scheduling movies

Dear Members,

I would like to ask the help of this group. I am working for a multimedia-broadcasting company and one of my main task is producing TV-schedules. I am doing it in excel, I have an excel sheet for every day of the month which I fill up data from other excel sheets (so called master libraries). My question would be: is it possible to create an excel template that can automatically fetch the data from different excel sheets? It would be great if I could give a range of the data which it should look up and than it would pick a random movie for copying.
I've created an example Excel workbook, please find it here: https://dl.dropbox.com/u/48496201/Example_1.xlsm

I have five worksheets in the example: Action, Thriller, Documentary and Sci-Fi for the different movies and one for the schedule template. In the template I have blocks for the movies, different movies have to be aired at different times. The first one has to be a Thriller, the macro for the first slot is:

Sub Button1_Thriller()

Dim ShFrom
Dim ShTo
Dim RngFrom
Dim RngTo

ShFrom = InputBox("Name of Sheet to copy data from:", Default:="Thriller")
RngFrom = InputBox("Range of data to copy:", Default:="A2:C30")
ShTo = InputBox("Name of Sheet to paste data to:", Default:="Schedule Template")
RngTo = InputBox("Range where data will be pasted:", Default:="D9:F9")

Sheets(ShFrom).Activate
ActiveSheet.Range(RngFrom).Select
Selection.Font.Bold = True
ActiveSheet.Range(RngFrom).Copy
Sheets(ShTo).Activate
ActiveSheet.Range(RngTo).PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False

End Sub

My problem is that I do not know how to tell that one film has to be picked from the Range.
I also want to add a line that says if the one movie is picked is bold, than search for an other within the range until it finds one which is not bold. After it copies to the template, make it bold both in the template and in the worksheet so it is not going to be scheduled again.

I would like to use pretty much the same macros for the other slots, I only have to adjust them so they pick the correct workbooks and correct ranges (and the correct number of movies within the ranges since there are slots for five movies).

Can someone help how to mend this code? Or instead of working with ranges, is there an better solution? Any feedback is appreciated!

Thank you,
Attila

Hi,

this code should work, give it a try. If there's something wrong with it, please tell me.

Sub MyTry()
'declare variables
Dim ShFrom As Worksheet, ShTo
Dim RngTo As Range
Dim MyArray()
Dim a As Integer, i, x
'give values to variables
Set ShFrom = Sheets("Thriller") '<-- change this if you want
Set ShTo = Sheets("Schedule Template")
ShTo.Activate
Set RngTo = Application.InputBox("Select destination cell:" _
            & vbCrLf & "(macro picks up row value)", _
            "Row where data will be pasted", Type:=8)
'store not bolded row's numbers in array
For i = 2 To ShFrom.Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 1).Font.Bold = False Then
        ReDim Preserve MyArray(a)
        MyArray(a) = i
        a = a + 1
    End If
Next i
'randomly pick one, copy it to schedule template and bold it
x = Int((a - 0 + 1) * Rnd + 0)
ShTo.Range("D" & RngTo.Row) = ShFrom.Range("A" & MyArray(x))
ShTo.Range("E" & RngTo.Row) = ShFrom.Range("B" & MyArray(x))
ShTo.Range("F" & RngTo.Row) = ShFrom.Range("C" & MyArray(x))
ShFrom.Range("A" & MyArray(x), "C" & MyArray(x)).Font.Bold = ture
End Sub

Hello Gergo,

thank you for your reaction! I've tested your code, in the last but one row I've corrected ture to True.

ShFrom.Range("A" & MyArray(x), "C" & MyArray(x)).Font.Bold = ture

The mechanism that picks the movie from the Thriller sheet and copies it to the Template works perfectly!
With the rest, I have a little issue: It should only pick movies from the Thriller sheet which are not bold. Unfortunately, that doesn't work now, I've tried out to bold a lot of titles and run the macro, it picks also movies which were already bold before the picking.

Perhaps can you help me with this?

Thank you,
Attila

Hi,

thanks for correcting.

I found the mistake in my code, I referenced a range from the incorrect worksheet. It should work now. I also erased the array at the end of the procedure, because it's good practice according to experts. (Frees up memory and maybe other benefits?)

Sub MyTry()
'declare variables
Dim ShFrom As Worksheet, ShTo
Dim RngTo As Range
Dim MyArray()
Dim a As Integer, i, x

'give values to variables
Set ShFrom = Sheets("Thriller") '<-- change this if you want
Set ShTo = Sheets("Schedule Template")
ShTo.Activate
Set RngTo = Application.InputBox("Select destination cell:" _
            & vbCrLf & "(macro picks up row value)", _
            "Row where data will be pasted", Type:=8)
'store not bolded row's numbers in array
For i = 2 To ShFrom.Cells(Rows.Count, 1).End(xlUp).Row
    If ShFrom.Cells(i, 1).Font.Bold = False Then
        ReDim Preserve MyArray(a)
        MyArray(a) = i
        a = a + 1
    End If
Next i
'randomly pick one, copy it to schedule template and bold it
x = Int((a - 0 + 1) * Rnd + 0)
ShTo.Range("D" & RngTo.Row) = ShFrom.Range("A" & MyArray(x))
ShTo.Range("E" & RngTo.Row) = ShFrom.Range("B" & MyArray(x))
ShTo.Range("F" & RngTo.Row) = ShFrom.Range("C" & MyArray(x))
ShFrom.Range("A" & MyArray(x), "C" & MyArray(x)).Font.Bold = True

Erase MyArray

End Sub

Hi Gergo,

This code works perfectly!

I use an extension of your code so it can pick five random movies from the array and copy it in the template. Here it is:"

Sub Button2_Documentary_Final()
'declare variables
Dim ShFrom As Worksheet, ShTo
Dim RngTo As Range
Dim MyArray()
Dim a As Integer, i, x, y, c, d, e

'give values to variables
Set ShFrom = Sheets("Documentary") '<-- change this if you want
Set ShTo = Sheets("Schedule Template")
ShTo.Activate
Set RngTo = Application.InputBox("Select destination cell:" _
            & vbCrLf & "(macro picks up row value)", _
            "Row where data will be pasted", Type:=8)
'store not bolded row's numbers in array
For i = 2 To ShFrom.Cells(Rows.Count, 1).End(xlUp).Row
    If ShFrom.Cells(i, 1).Font.Bold = False Then
        ReDim Preserve MyArray(a)
        MyArray(a) = i
        a = a + 1
    End If
Next i
'randomly pick one, copy it to schedule template and bold it
x = Int((a - 0 + 1) * Rnd + 0)
ShTo.Range("D" & RngTo.Row) = ShFrom.Range("A" & MyArray(x))
ShTo.Range("E" & RngTo.Row) = ShFrom.Range("B" & MyArray(x))
ShTo.Range("F" & RngTo.Row) = ShFrom.Range("C" & MyArray(x))
ShFrom.Range("A" & MyArray(x), "C" & MyArray(x)).Font.Bold = True

y = Int((a - 0 + 1) * Rnd + 0)
ShTo.Range("D" & RngTo.Row + 1) = ShFrom.Range("A" & MyArray(y))
ShTo.Range("E" & RngTo.Row + 1) = ShFrom.Range("B" & MyArray(y))
ShTo.Range("F" & RngTo.Row + 1) = ShFrom.Range("C" & MyArray(y))
ShFrom.Range("A" & MyArray(y), "C" & MyArray(y)).Font.Bold = True

c = Int((a - 0 + 1) * Rnd + 0)
ShTo.Range("D" & RngTo.Row + 2) = ShFrom.Range("A" & MyArray(c))
ShTo.Range("E" & RngTo.Row + 2) = ShFrom.Range("B" & MyArray(c))
ShTo.Range("F" & RngTo.Row + 2) = ShFrom.Range("C" & MyArray(c))
ShFrom.Range("A" & MyArray(c), "C" & MyArray(c)).Font.Bold = True

d = Int((a - 0 + 1) * Rnd + 0)
ShTo.Range("D" & RngTo.Row + 3) = ShFrom.Range("A" & MyArray(d))
ShTo.Range("E" & RngTo.Row + 3) = ShFrom.Range("B" & MyArray(d))
ShTo.Range("F" & RngTo.Row + 3) = ShFrom.Range("C" & MyArray(d))
ShFrom.Range("A" & MyArray(d), "C" & MyArray(d)).Font.Bold = True

e = Int((a - 0 + 1) * Rnd + 0)
ShTo.Range("D" & RngTo.Row + 4) = ShFrom.Range("A" & MyArray(e))
ShTo.Range("E" & RngTo.Row + 4) = ShFrom.Range("B" & MyArray(e))
ShTo.Range("F" & RngTo.Row + 4) = ShFrom.Range("C" & MyArray(e))
ShFrom.Range("A" & MyArray(e), "C" & MyArray(e)).Font.Bold = True

Erase MyArray

End Sub

Thank you so much for your time!

Greetings,

Attila