[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Merge Cells

Posted on 2011-11-01
6
Medium Priority
?
421 Views
Last Modified: 2012-05-12
Hi Experts,

I would like to request Experts help create a macro to automatically merge the empty cells with the content cell vertically at week1 to week5 sheets. I have manually merged few cells at week 1 (1-4 nov) for Experts to get better view. Hope Experts could help me create this feature. Attached the workbook for Experts perusal.
Copy-DataNew.xls
0
Comment
Question by:Cartillo
  • 3
  • 2
6 Comments
 
LVL 12

Expert Comment

by:kgerb
ID: 37063327
Try this.  It will loop through sheets Week1 through Week5 and merge the correct cells.  Let me know if it's not what you want.

Kyle
Sub MergeCells()
Dim c As Range, firstaddress As String, rng As Range, i As Long, asht As Worksheet
Set asht = ActiveSheet
For i = 1 To 5
    Sheets("Week" & i).Activate
    Set rng = Sheets("Week" & i).Range("B4:H98")
    With rng
        Set c = .Find("*")
        If Not c Is Nothing Then
            firstaddress = c.Address
            Do
                If c.Offset(1) = "" Then
                    If c.End(xlDown).Row <> Rows.Count Then
                        Range(c, c.End(xlDown).Offset(-1)).Merge
                    Else
                        Range(c, Cells(rng.Cells(rng.Cells.Count).Row, c.Column)).Merge
                    End If
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
    End With
Next i
asht.Activate
End Sub

Open in new window

0
 
LVL 17

Expert Comment

by:gtgloner
ID: 37063328
Question: Do you want the blank cells immediately below ones with data to be merged with the data cells? I am having trouble seeing a pattern by which some VBA code might be written to do what you want...
0
 

Author Comment

by:Cartillo
ID: 37063756
Hi Kyle,

Thanks a lot for the code. Is that any chance to automatically wrap text set the font size to 6? The actual data usually more longer (sometime up to 60 words). Hope you will consider.
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
LVL 12

Accepted Solution

by:
kgerb earned 2000 total points
ID: 37063961
Here's a modified version.  It wraps text, change font size to 6, and re-does the borders.  I found the merging was messing up the formatting so this fixes it.  

Thanks
Kyle
Sub MergeCells()
Dim c As Range, firstaddress As String, rng1 As Range, rng2 As Range
Dim i As Long, asht As Worksheet
Set asht = ActiveSheet
For i = 1 To 5
    Sheets("Week" & i).Activate
    Set rng1 = Sheets("Week" & i).Range("B4:H98")
    With rng1
        Set c = .Find("*")
        If Not c Is Nothing Then
            firstaddress = c.Address
            Do
                If c.Offset(1) = "" Then
                    If c.End(xlDown).Row <> Rows.Count Then
                        Set rng2 = Range(c, c.End(xlDown).Offset(-1))
                    Else
                        Set rng2 = Range(c, Cells(rng1.Cells(rng1.Cells.Count).Row, c.Column))
                    End If
                    With rng2
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .WrapText = True
                        .MergeCells = True
                    End With
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
    End With
    With rng1
        .Font.Size = 6
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Color = RGB(192, 192, 192)
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Color = RGB(192, 192, 192)
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Color = RGB(192, 192, 192)
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Color = RGB(192, 192, 192)
        End With
    End With
Next i
asht.Activate
End Sub

Open in new window

0
 

Author Closing Comment

by:Cartillo
ID: 37064187
Hi Kyle,

Thanks a lot for the solution.
0
 

Author Comment

by:Cartillo
ID: 37064436

Hi Kyle,

Hope you will consider this request. The question is to unmerge cells and revert the worksheet into the default format .

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_27426005.html
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

834 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question