CODEWITHSUNDEEP
arraysexcelvbamerge
ChangeWorld
ChangeWorld

Reputation: 431

Merging Cells in Excel from an Array

Here is what I'm trying to accomplish: Cell B2: Start Date and Cell B3: End Date

Example:
B2 --> 01/01/2019
B3 --> 01/03/2019

Example Excel

I have an array with the week numbers between these two dates. Example array (1, 2, 3, 4, 5, 6, 7, 8, 9), including the last week of February(week 9). I'm Working on a Planning excel that's why I'm considerating also week 9 (We had some issues in the last post, that's why I'm explaining it)

Here is my code for obtaining this array 

Sub FillCal()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim StartDate As Range, EndDate As Range
Dim NoOfWeeks As Long
Dim arr As Variant
Dim i As Long

With Worksheets("Foglio1")
    Set StartDate = .Range("B2")
    Set EndDate = .Range("B3")
End With

NoOfWeeks = WorksheetFunction.RoundUp((EndDate.Value2 - StartDate.Value2) / 7, 0)

ReDim arr(1 To NoOfWeeks)
For i = 1 To NoOfWeeks
    arr(i) = i
Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

What I'm trying to do is: Starting from Cell D4, put the 1st value of the array arr in it and merge cells E4 and F4 with it(so cells D4, E4, F4 merged with value 1), put next value of the array(in this case Cell G4 and value 2) in it and merge the 2 other cells on the right so it would be Cells G4, H4, I4 with value 2 and so on... till last value of the array (Sorry for bad English I will attach a photo for better understanding)

Here is the output that I would like to obtain:

Better understanding

So Its basically: merge every 3 cells.

Since an user asked for it, here is how I try to merge...

i = wks.Range("A3").End(xlToRight).Row
Set rngMerge = wks.Range("A3:XZ3" & i) ' Find last row in column A

With wks

checkAgain:
For Each rngCell In rngMerge

    If rngCell.Value = rngCell.Offset(0, 1).Value And IsEmpty(rngCell) =        False Then

        Range(rngCell, rngCell.Offset(0, 1)).Merge
        rngCell.VerticalAlignment = xlCenter
        rngCell.HorizontalAlignment = xlCenter
        rngCell.BorderAround ColorIndex:=1

        GoTo checkAgain
    End If

Next
End With

Upvotes: 1

Views: 360

Answers (2)

GMalc
GMalc

Reputation: 2628

You actually don't need to use an array, since you are assigning NoOfWeeks as a variable;

Just replace this portion of your first code...

ReDim arr(1 To NoOfWeeks)
For i = 1 To NoOfWeeks
    arr(i) = i
Next i

With this code...

x = 4

For i = 1 To NoOfWeeks
    With Cells(3, x)
        .Value = i
        .Resize(, 3).Merge
        .HorizontalAlignment = xlCenterAcrossSelection
    End With
    x = x + 3
Next i

Upvotes: 0

Vityata
Vityata

Reputation: 43575

Starting for D4 as a "given", point and merging any 3 cells as far as there is something in the array, this is what I have managed to build:

enter image description here

This is the code:

Sub TestMe()

    Worksheets(1).Cells.Delete

    Dim myCellToStart As Range
    Set myCellToStart = Worksheets(1).Range("D4")

    Dim myArray As Variant
    myArray = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)

    Dim myVar As Variant
    Dim myCell As Range
    Set myCell = myCellToStart

    For Each myVar In myArray

        Set myCell = Worksheets(1).Range(myCell, myCell.Offset(, 2))

        myCell.Merge
        BorderMe myCell
        myCell = myVar

        Set myCell = myCell.Offset(, 1)

    Next myVar

End Sub

The "trick" is to define the range to be merged correctly. It is carried out with Set myCell = Worksheets(1).Range(myCell, myCell.Offset(, 2)) and with Set myCell = myCell.Offset(, 1) to mark the new start.

And this is the "Bordering" function:

Public Sub BorderMe(myRange As Range)

    Dim cnt As Long

    For cnt = 7 To 10 '7 to 10 are the magic numbers for xlEdgeLeft etc
        With myRange.Borders(cnt)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
    Next

End Sub

Upvotes: 2

Related Questions