Merge cells using VBA

[jag108]

Hi,

I have a spread sheet that contains program schedules for sattelite TV. The rows contain times from 06:00 (Start of Day) to the end of the broadcast day 29:00hr (dont ask if yor not into broascasting) in half hour increments (two rows per increment) so four rows covers 1 hour, the columns contain the days of the week. What I need this code to do is check the columns of progames, if they span more than their own time slot then merge and wrap the text so that the cells look like one programmed slot.

06:00, Golf: Presidents Cup LIVE, Presidents Cup, 6, Presidents Cup, FSI/World Feed sat Feed LIVE ( TIMES TBC),


06:55, UK Super League Live, Teams Tba Live, 62, UK Super League, TWI/BSKYB/Sat Feed LIVE,










09:30, Gilllette World Sport, Gillette World Sport, 39, Gillette World Sport,

10:00, Football Euro, Golazo!, 88, Football Euro,



11:00, Baseball Live, Teams Tba Live, 23, Baseball, ESPN 1A/Sat Feed LIVE,










13:50, Ing Golf Club, Ing Golf Club, 34, Ing Golf Club,
14:00, WRC Rally World, Rally World, 28, Wrc Rally World,

14:30, Rugby: Air NZ NPC LIVE, Otago V Canterbury Live, 73, Air NZ NPC Rugby 2005, SKY OB LIVE, 14:30, Rugby: Air NZ NPC LIVE, Northland V Southland Live, 79, Air NZ NPC Rugby 2005, SKY OB LIVE,

15:00, Gillette World Sport, Gillette World Sport, 38, Gillette World Sport,

15:30, NASCAR Highlights, Mbna 400 Highlights, 32, NASCAR Nextel Cup Series,

16:00, Ladies European Golf, Klm Ladies Open, 17, Ladies European Tour, Parallel Media Tape, 16:00, Football: Junior Knights, Young Knights, 6, Young Knights, SKY Tape, 16:01, Courtside, Courtside, 4, Courtside,

16:30, Premier League Snooker Yr: 200, Premier League Snooker, 22, Premier League Snooker, 16:30, Local Hero, Local Heroes, 5, Local Heroes, SKY Tape, 16:30, XS TV, X S T V, 33, X S T V,

17:00, Bowls: International Challenge, Bowls: International Challenge Series, 3, Bowls: International Challenge Series, 17:00, Kick Back, Kick Back, 5, Kick Back, SKY OB LIVE/ St1 VT Playout,

17:30, Golf: US PGA Tour H/l's, R SS1 am, 17:30, The Pay Per View Preview Show, Pay Per View Preview Show, The, 31, Pay Per View Preview Show, The, 17:30, Gillette World Sport, Gillette World Sport, 39, Gillette World Sport, 17:30, Rugby: Air NZ NPC LIVE, Waikato V Bay Of Plenty Live, 75, Air NZ NPC Rugby 2005, SKY OB LIVE,

18:00, Reunion Replay, Reunion Replay, 32, Reunion Replay,

18:30, Fishing NZ, Fishing NZ, 1, Fishing NZ, RS2 27/9, 18:30, Sport 365 Live, Sport 365 Live, 30, Sport 365 Live,

19:00, Car Crazy, Pebble Beach, 22, Meguiar's Car Crazy, Meguiars Tape (Smits Group), 19:00, Courtside, Courtside, 4, Courtside, 19:00, NZ Burton Open, 2005 Burton Cup, 3, 2005 Burton Open, 19:00, Friday Night Football - LIVE, Friday Night Football, 21, Friday Night Football, SKY OB LIVE, 19:00, NRL Full Time, NRL Full Time, 30, NRL Full Time,

19:30, Try Time, Try Time, 31, Try Time, 19:30, ING Golf, Ing Golf, 32, Ing Golf, 19:30, XS TV, X S T V, 33, X S T V, 19:30, Soccer: Hyundai A League Highl, Soccer: Hyundai A-league Highlights, 6, Soccer: Hyundai A-league Highlights, SKY Tape (deano), 19:30, Rugby: Air NZ NPC LIVE, Auckland V Wellington Live, 71, Air NZ NPC Rugby 2005, SKY OB LIVE, 19:30, Rugby: Air NZ NPC LIVE, North Harbour V Taranaki Live, 77, Air NZ NPC Rugby 2005, SKY OB LIVE,

20:00, Sport 365 Live, Sport 365 Live, 26, Sport 365 Live, 20:00, ING Golf Club, Ing Golf Club, 34, Ing Golf Club, 20:00, NZ Freeski Nationals, R SS1 29th, 20:01, On Sky Sport, On Sky Sport, 33, On Sky Sport,

20:30, Deaker on Sport Live, Deaker On Sport Live, 32, Deaker On Sport, 20:30, Reunion, Reunion, 32, Reunion, 20:30, Heartland Rugby, Toyota Heartland Rugby, 7, Toyota Heartland Rugby, 20:30, NZ Free Ski Nationals, Picture x tape, 20:30, The Fishing Show, Fishing Show, The, 7, Fishing Show, The,

21:00, Fishing NZ, Fishing NZ, 1, Fishing NZ, RS1 27/9, 21:00, NRL Grand Final LIVE, Ch9/Sat Feed LIVE,

21:31, Soccer: Fa Premiership Highlig, Soccer: Fa Premiership Highlights, 6, Soccer: Fa Premiership Highlights, 21:30, Sport 365 Headlines, Sport 365 Headlines, 27, Sport 365 Headlines, 21:35, AFL Highlights Yr: 2005, AFL Highlights, 27, AFL Highlights, 21:30, Sport 365 Headlines, Sport 365 Headlines, 28, Sport 365 Headlines, 21:35, Speedway Grand Prix Series, Round 2 Sweden, 3, Speedway Grand Prix 2005, Benfield Tape, 21:30, Sport 365 Headlines, Sport 365 Headlines, 29, Sport 365 Headlines, 21:35, FIM Motocross World Champs H/l, Grand Prix Of Ireland, 18, Fim Motocross World Championship, Youthstreme Tape ( GP of ireland),
21:50, World Superbike Championships, St1/FG Sports/Sat Feed LIVE (Imola, Italy),
22:01, Soccer: Fa Premiership Preview, Soccer: Fa Premiership Preview, 7, Soccer: Fa Premiership Preview,

22:30, Fivb Beach Volleyball, Paris, France, 8, Fivb/swatch World Tour Beach Volleyball 2005, IEC Tape, 22:31, Fishing Show, The, Fishing Show, The, 6, Fishing Show, The, 22:30, NZ Performance Car TV Yr: year, NZ Performance Car TV, 2, NZ Performance Car TV,

23:00, ITU World Triathlon Champs H/l, Gamagori, Japan, 12, Itu World Triathlon Series, BBC Tape, 23:00, Inside The PGA Tour, Inside The PGA Tour, 39, Inside The PGA Tour,

23:30, The Pay Per View Preview Show, Pay Per View Preview Show, The, 31, Pay Per View Preview Show, The,

24:00, Deaker On Sport Replay, Deaker On Sport Replay, 30, Deaker On Sport, 24:00, XS TV, X S T V, 33, X S T V,



25:00, NZ Performance Car TV Yr: year, NZ Performance Car TV, 2, NZ Performance Car TV,
25:20, World Superbike Championship, St1/FG Sports/Sat Feed LIVE (Imola, Italy),



















The cols are supposed to be 85 px wide.

The coe dI am using will not pick up the first cell B8 and merge it with b9:b43 the code used is


Sub Merge_Slots()
Cells(8, 2).Select
For Each cell In ActiveSheet.Range("Programmes")
If Not cell.Value = emtpy Then
For i = 1 To 103 Step 1

Next
End If
If cell.Value = Empty And cell.Offset(-1, 0).Borders(xlTop).Weight = xlThin And cell.Offset(-1, 0).Row <> 7 Then
'If cell.Value = "" And cell.Offset(-1, 0).Borders(xlTop).Weight = xlThin And cell.Offset(-1, 0).Row <> 7 Then
Range(Cells(cell.Row - 1, cell.Column), Cells(cell.Row, cell.Column)).Select
With Selection
.WrapText = True
.MergeCells = True
End With
End If
Next
End Sub

Thanks to all the wonderful assistance over the years!!!

 

[jag108]

Seems like the code to insert part of the spreadsheet did not work!

Ooops!