VBA - code for a single worksheet

[haitham1984]

Hello All,

I am writing a code that does the 2 steps listed below, a total of 50 times. Below is a description of what the code does.

Step 1) The code looks for a single cell to see if it is blank, or to be precise, if it is A1="". If the cell is empty (" "), then the code skips step 2 below. It then repeates steps 1 & 2, a further 49 times (50 times in total).

Step 2) The hard bit. Below is a table for a student's schedule (top row = time <from 8="" am="" -="" pm="">, 1st column = days <mon-fri>). The formatting I want is for the program to check if 2 (or more) adjacent cells are equal in content, then the code merges these equal cells. It can be that a course can last for 2 hours (each cell is 30 mins long), so I might need to merge 4 cells in total (30 mins x 4 cells = 2 hours). After merging is complete, the same process is repeated on a table underneath the first table.

Below is an example of a student's schedule:

Student Name: Student's_Name

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Time[/TD]
[TD]800-830[/TD]
[TD]830-900[/TD]
[TD]900-930[/TD]
[TD]930-1000[/TD]
[TD]1000-1030[/TD]
[TD]1030-1100[/TD]
[TD]1100-1130[/TD]
[TD]1130-1200[/TD]
[TD]1200-1230[/TD]
[TD]etc.[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mon[/TD]
[TD]Math1[/TD]
[TD]Math1[/TD]
[TD][/TD]
[TD]English1[/TD]
[TD]English1[/TD]
[TD][/TD]
[TD]Chemistry1[/TD]
[TD]Chemistry1[/TD]
[TD]Chemistry1[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Tues[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]English1[/TD]
[TD]English1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Wed[/TD]
[TD]Math1[/TD]
[TD]Math1[/TD]
[TD][/TD]
[TD]English1[/TD]
[TD]English1[/TD]
[TD][/TD]
[TD]Chemistry1[/TD]
[TD]Chemistry1[/TD]
[TD]Chemistry1[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thurs[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]English1[/TD]
[TD]English1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fri[/TD]
[TD]Math1[/TD]
[TD]Math1[/TD]
[TD][/TD]
[TD]English1[/TD]
[TD]English1[/TD]
[TD][/TD]
[TD]Chemistry1[/TD]
[TD]Chemistry1[/TD]
[TD]Chemistry1[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Quick Explanation: First, the code checks if the cell for the student's name is empty (B2=""), if there no name, then the code goes to the student's name below the first table. If there is a name then the code goes to step 2 for Table 1. Math1 is an hour long course, so the code should merge Math1 from 800-900. Chemistry1 is an hour and a half long (3 cells), so I would like the code to check if the adjacent cells (to the right) are the same (in content) and merge them together. This process continues until the entire table has been checked for mergers.

The code then goes to the next student_name, below Table 1 and repeats the process 49 more times.

Thank you for any help you may provide.
Regards,
Haitham</mon-fri></from>

 

[CalcSux78]

Welcome to the forum H.

I am flying blind on what code you've already written or the layout of the worksheet, but here's a start:

Sub MergeHaitham()
Dim rng As Range, cel As Range
Dim rMerge As Range
Dim R&, C&
Dim str$


Set rng = ActiveSheet.UsedRange
For R = 1 To rng.Rows.Count
    For Each cel In rng.Rows(R).Cells
        Set rMerge = Nothing
        If Not cel = "" Then
            Set rMerge = cel
            For C = cel.Column + 1 To rng.Columns.Count
                If rng(R, C).Value = cel Then Set rMerge = Union(rMerge, Cells(R, C))
            Next C
            rMerge.Select
            If rMerge.Cells.Count > 1 Then
              Application.DisplayAlerts = Not Application.DisplayAlerts
                rMerge.Merge
                rMerge.HorizontalAlignment = xlCenter
              Application.DisplayAlerts = Not Application.DisplayAlerts
            End If
        End If
    Next cel
Next R
End Sub

The code will loop through all of the cells in each row within the Used Range of the worksheet looking for adjacent matching values. If found, it will merge those cells and Center align that range.