Formatting table with dynamic merged cells

[mani_bbc05]

Hi Friends,

I am facing a small problem with formatting a table. Table in the example will be pulled by a macro, so its range can increase or decrease based on it i am not able to find out how to merge the header row and find the last filled column to give border to the data.

Please find the sample data attached below

Thanks & Regards,

 

[SirJB7]

Hi, mani_bbc05!
Don't ever use merged cells, they suck. For getting a similar display experience use instead Center On Selection, from the Alignment properties display dialog.
Regards!

 

[mani_bbc05]

Hi, mani_bbc05!
Don't ever use merged cells, they suck. For getting a similar display experience use instead Center On Selection, from the Alignment properties display dialog.
Regards!

Thanks SirJB7 for the suggestion, but can you please help me to to that by keeping the range dynamic based on the maximum number of columns in the main data table.

 

[Marc L]

Hi,

see VBA help of CurrentRegion, UsedRange & End properties …

Regards !​

 

[SirJB7]

Hi, mani_bbc05!

No problem, I can help you by keeping on giving fish, but have you ever thought about learning how to fish by yourself? If I were you I'll surely follow Marc L's recommendation. He has a concise but surgeon precise style.

Give a look at this file:
https://dl.dropboxusercontent.com/u...rge cell (for mani_bbc05 at chandoo.org).xlsm

And this is the code, check the main procedure name:

Option Explicit

Sub ThisShouldHaveBeenDoneByTheUser()
    ' constants
    Const ksSourceWS = "Sheet1"
    Const ksSourceRange = "SourceTable"
    Const ksTargetWS = "Sheet2"
    Const ksTargetRange = "TargetTable"
    ' declarations
    Dim rngS As Range, rngT As Range
    Dim I As Long, A As String
    ' start
    Set rngS = Worksheets(ksSourceWS).Range(ksSourceRange)
    Set rngT = Worksheets(ksTargetWS).Range(ksTargetRange)
    ' process
    With rngT
        Worksheets(ksTargetWS).Activate
        ' clear titles, if available
        If .Row > 1 Then
            .Parent.Rows(.Row - 1).Cells.Clear
            If .Row > 2 Then
                .Parent.Rows(.Row - 2).Cells.Clear
            End If
        End If
        ' clear data
        .Cells.Clear
        ' copy data
        rngS.Copy .Cells(1, 1)
        ' resize
        Set rngT = .Resize(, .CurrentRegion.Columns.Count)
        ' format
        .Cells.Style = "Percent"
        SetBorders1 rngT
        SetBorders2 Range(rngT.Columns(2), rngT.Columns(rngT.Columns.Count))
        ' add titles if available
        If .Row > 1 Then
            .Parent.Cells(.Row - 1, .Column).Value = "Group"
            .Parent.Cells(.Row - 1, .Column + 1).Value = "Percentage share"
            Range(.Parent.Cells(.Row - 1, .Column + 1), .Parent.Cells(.Row - 1, .Column + rngT.Columns.Count - 1)).Select
            With Selection
                .HorizontalAlignment = xlCenterAcrossSelection
                Range(.Offset(0, -1), Selection).Select
            End With
            With Selection
                .Font.Bold = True
                .Interior.Color = &HB7B8E6
                SetBorders1 Selection
            End With
            If .Row > 2 Then
                .Parent.Cells(.Row - 2, .Column).Value = "North East Market Share"
                Range(.Parent.Cells(.Row - 2, .Column), .Parent.Cells(.Row - 2, .Column + rngT.Columns.Count - 1)).Select
                With Selection
                    .HorizontalAlignment = xlCenterAcrossSelection
                    .Font.Bold = True
                    .Interior.Color = &H9496DA
                    SetBorders1 Selection
                End With
            End If
        End If
        .Cells(1, 1).Select
    End With
    ' end
    Set rngT = Nothing
    Set rngS = Nothing
    Beep
End Sub

Private Sub SetBorders1(prRange As Range)
    With prRange
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
    End With
End Sub

Private Sub SetBorders2(prRange As Range)
    With prRange
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
End Sub

Regards!

 

[mani_bbc05]

Thanks SirJB7 for your help.

 

[SirJB7]

Hi, mani_bbc05!
Glad you solved it. Thanks for your feedback and welcome back whenever needed or wanted.
Regards!
PS: Take seriously my previous advice.