CODEWITHSUNDEEP
excelvba
Brenton
Brenton

Reputation: 274

Dynamically Merge & Center Cells by variable value using VBA

I am trying to Merge & Center x number of cells using a static starting point with VBA.

My starting point will always be Cell D69 and I will always be merging columns D - I together starting at Row 69 and then aligning the text to the left.

My current macro for this looks like this:

Range("D69:I69").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.merge
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With

I need to continue this process for the rows after row 69 x number of times. I am having a difficult time trying to implement a loop that uses x as my number of iterations, and also the starting point being Row 69 + number of iterations as the row reference point.

Upvotes: 0

Views: 2342

Answers (2)

FAB
FAB

Reputation: 2569

See if this helps, more details in the code comments:

Sub mergeThis()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("SheetName") 'declare and set the worksheet, set your sheet name.
Dim X As Long, howManyTimes As Long 'declare variables to use

howManyTimes = 100 'set how many times here. See additional code for how to get this to last row instead


    For X = 0 To howManyTimes 'loop from 0 to so many times
        With ws.Range("D69:I69").Offset(X) 'use offset from range to get the new range to deal with
            .MergeCells = True
            .HorizontalAlignment = xlLeft
        End With
    Next X
End Sub

I've removed all the default values from merge/format, it makes no difference if they are not set to a different value.

Now there are ways of getting last row, if that's what you need to get to. Just add:

Dim lRow As Long: lRow = ws.Cells(Rows.Count, 4).End(xlUp).Row

howManyTimes = lRow

Upvotes: 1

urdearboy
urdearboy

Reputation: 14580

  1. Determine last row
  2. Loop through each row (starting at 69) merging from D to I
  3. After the loop is complete, format the entire range all at once

This also checks to make sure your last row is indeed greater than 69 otherwise this will give an error.

Option Explicit

Sub Merge_For_Client()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update Sheet
Dim LR As Long, i As Long

LR = ws.Range("D" & ws.Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    If LR >= 69 Then

        For i = 69 To LR
            ws.Range(ws.Cells(i, "D"), ws.Cells(i, "I")).Merge
        Next i

        With ws.Range(ws.Cells(69, "D"), ws.Cells(LR, "I"))
            .HorizontalAlignment = xlLeft
            'Add any other formats you want to apply in this With Block
        End With

    End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Upvotes: 2

Related Questions