I am trying to merge every 3 cells of row 1 (starting with B1, and the last cell to be merged is FY - meaning FW, FX & FY should be merged.). I have used this to merge every 3 rows going down a column, but how would I alter this to go across row 1?
Function MergeHeaders()
Application.DisplayAlerts = False
Dim RgToMerge As Range
For i = 3 To ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row Step 3
Set RgToMerge = Range(Cells(i, 3), Cells(i + 1, 3))
With RgToMerge
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
End Function
Something more like this?
Function MergeHeaders()
Dim RgToMerge As Range
Application.DisplayAlerts = False
For i = 2 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column Step 3
Set RgToMerge = Range(Cells(1, i), Cells(1, i + 2))
With RgToMerge
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
End Function
Related
I want to merge cells two in columns A and B, for example like bellow, and so as long as I have records, below is my code but does not work and does not merge cells do not know what the problem. thanks
.Range("A5", "A6").Merge
.Range("A7", "A8").Merge
.Range("A9", "A10").Merge
.Range("B5", "B6").Merge
.Range("B7", "B8").Merge
.Range("B9", "B10").Merge
Dim i As Integer
Dim j As Integer
Dim xlMerge As Range
Dim xlMergeJ As Range
For i = 5 To ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row Step 2
Set xlMerge = Range(Cells(i, 1), Cells(i + 1, 1))
With xlMerge
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
For j = 5 To ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row Step 2
Set xlMergeJ = Range(Cells(j, 2), Cells(j + 1, 1))
With xlMergeJ
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next j
maybe you're after this:
Option Explicit
Sub main()
Dim i As Long
With ActiveSheet
For i = 5 To .Cells(Rows.count, 1).End(xlUp).row Step 2
With .Cells(i, 1).Resize(2)
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
With .Cells(i, 2).Resize(2)
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
End With
End Sub
or its shorter option:
Sub main()
Dim i As Long
With ActiveSheet
For i = 5 To .Cells(Rows.count, 1).End(xlUp).row Step 2
With .Range(.Cells(i, 1).Resize(2).Address & "," & .Cells(i, 2).Resize(2).Address)
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
End With
End Sub
I am making a table in VBA, and as you can see in my sample table here, I have certain merges about every 2 rows of cells made dependent on various cells. However, a part of the table that can be static is column C in the dark gray. I simply want it to do a number count starting at 1 and continuing to the end of my table but skipping the red horizontal lines and leaving them blank. So, red would be 1, orange 2, yellow 3, etc. Here is the code I want to make more efficient. I could type out every number, but that just seems so inefficient.
range("C3:C8").Select
ActiveCell.FormulaR1C1 = "1"
With Selection
.MergeCells = True
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlBottom
End With
range("C10:C12").Select
ActiveCell.FormulaR1C1 = "2"
With Selection
.MergeCells = True
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
range("C9:C10").Select
ActiveCell.FormulaR1C1 = "3"
With Selection
.MergeCells = True
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
I would use that there is text in column D.
Sub add_counter()
'Created by Fredrik Östman www.scoc.se
counter = 1
For i = 7 To ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row
If Cells(i, 4) <> "" Then
Cells(i, 3) = counter
With Range(Cells(i, 3), Cells(i + 1, 3))
.MergeCells = True
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlBottom
End With
counter = counter + 1
End If
Next i
End Sub
I am facing the problem to proecess a report I got into a useful structured excel model.
My problem is that cells in this report are merged and now I would like to unmerge them to process the information much easier.
I tried to record something using the macro recorder, but I am unsure how to automate it on every cell in the sheet.
I would like to let the output look like that:
This is the part I recorded:
Sub Macro1()
Range("A2:A3").Select
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A3")
Range("A2:A3").Select
End Sub
Any suggestions how to rewrite this macro to do the merging and pasting automatically?
Appreciate your replies!
UPDATE
I tried to use the selection, however, I am currently facing the problem of not knowing how to get next cell:
Sub split()
'
'Dim C As Double
'Dim R As Double
Dim Rng As Range
'select cells
Set Rng = Selection
'C = Rng
'R = 10
For Each cell In Rng
'starts in row 2 and A -> cell 2,1 is the first cell or A2
cell.Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
'Cells(R + 1, C) = Cells(R, C)
If cell.Value = "" Then MsgBox ("Finished splitting and copying!"): End
' If C = 7 Then C = 0: R = R + 2
Next cell
End Sub
Sub Macro1()
NbRows = Sheets("Feuil1").UsedRange.Rows.Count - 1
NbCols = 9 ' If it doesn't change
Range("A2:I11").Copy Destination:= _
Range("K2")
Range("K:S").MergeCells = False ' remove merge
For i = 2 To NbRows ' Number of rows
For j = 11 To NbCols + NbCols ' Number of cols
If Cells(i, j) = "" Then
Cells(i, j) = Cells(i - 1, j).Value
End If
Next j
Next i
End Sub
My code copy-paste the datas from the first table to the cell "K2" (as in your example). Then, you remove the merge that will left some blanks. What you want to do is if cells(i , 1) is empty, then you just use the data from above (cells(i-1, 1))
if the data you want to change is on columns a to g and your are starting from row 2 and assuming all of the cell are not empty
try this code:
Sub split()
'
Dim C As Double
Dim R As Double
C = 1
R = 2
For C = 1 To 7
Cells(R, C).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
Cells(R + 1, C) = Cells(R, C)
If Cells(R, C).Value = "" Then MsgBox ("PROJECT ENDED"): End
If C = 7 Then C = 0: R = R + 2
Next C
End Sub
Please save your data before running the macro. You cannot undo.
I have written a macro in VBA, but am facing two problems:
I keep getting reference is not valid error.
Horizontal alignment of merged cells does not work.
Here is the sub:
Sub test(numCell As Integer)
Dim rowNum As Integer
Dim colNum As Integer
rowNum = ActiveCell.Row
colNum = ActiveCell.Column
With Range(Cells(rowNum, colNum), Cells(rowNum, colNum + numCell - 1))
.Merge (Across)
.Interior.Color = 200
.BorderAround LineStyle:=xlContinuous
.BorderAround Color:=1
.Borders(xlEdgeBottom).Color = 1
.Borders(xlEdgeTop).Color = 1
.Borders(xlEdgeLeft).Color = 1
.Borders(xlEdgeRight).Color = 1
.Borders.Weight = xlThick
.Value = Str(numCell)
.VerticalAlignment = xlCenterAcrossSelection
.HorizontalAlignment = xlCenterAcrossSelection
End With
End Sub
Two errors were fixed on these lines: .Merge and .VerticalAlignment = xlVAlignCenter. I think I changed nothing else and the code works.
Sub test(numCell As Integer)
Dim rowNum As Integer
Dim colNum As Integer
rowNum = ActiveCell.Row
colNum = ActiveCell.Column
With Range(Cells(rowNum, colNum), Cells(rowNum, colNum + numCell - 1))
.Merge
.Interior.Color = 200
.BorderAround LineStyle:=xlContinuous
.BorderAround Color:=1
.Borders(xlEdgeBottom).Color = 1
.Borders(xlEdgeTop).Color = 1
.Borders(xlEdgeLeft).Color = 1
.Borders(xlEdgeRight).Color = 1
.Borders.Weight = xlThick
.Value = Str(numCell)
.VerticalAlignment = xlVAlignCenter
.HorizontalAlignment = xlCenterAcrossSelection
End With
End Sub
I have the following:
I expect the following:
I am using this code:
Sub merge_cells()
Application.DisplayAlerts = False
Dim r As Integer
Dim mRng As Range
Dim rngArray(1 To 4) As Range
r = Range("A65536").End(xlUp).Row
For myRow = r To 2 Step -1
If Range("A" & myRow).Value = Range("A" & (myRow - 1)).Value Then
For cRow = (myRow - 1) To 1 Step -1
If Range("A" & myRow).Value <> Range("A" & cRow).Value Then
Set rngArray(1) = Range("A" & myRow & ":A" & (cRow + 0))
Set rngArray(2) = Range("B" & myRow & ":B" & (cRow + 0))
Set rngArray(3) = Range("C" & myRow & ":C" & (cRow + 0))
Set rngArray(4) = Range("D" & myRow & ":D" & (cRow + 0))
For i = 1 To 4
Set mRng = rngArray(i)
mRng.Merge
With mRng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next i
myRow = cRow + 2
Exit For
End If
Next cRow
End If
Next myRow
Application.DisplayAlerts = True
End Sub
what I get is:
Question: how to achieve this?
Actually in my original data, the first three columns have data every 88 rows starting from row 3 and the column D should get merged every four rows.
Your code does not distinguish between the different columns in any way. If you know how many rows to merge you can simply search for cells and then do the merge based on column number. Here is one such approach which uses a pair of arrays to track how many rows to merge and then what formatting to apply.
You will need to change the row counts in the array definition. Sounds like you want (87,87,87,3) based on your edit. I did (11,11,11,3) to match your example though. This is the real fix to your code; it uses the Column number to determine how many rows to merge.
I also just typed some values into the spreadsheet and used SpecialCells to get only the cells with values. If your data matches your example, this works fine.
Edit includes unmerging cells first per OP request.
Sub MergeAllBasedOnColumn()
Dim rng_cell As Range
Dim arr_rows As Variant
Dim arr_vert_format As Variant
'change these to the actual number of rows
'one number for each column A, B, C, D
arr_rows = Array(11, 11, 11, 3)
'change these if the formatting is different than example
arr_vert_format = Array(True, True, True, False)
'unmerge previously merged cells
Cells.UnMerge
'get the range of all cells, mine are all values
For Each rng_cell In Range("A:D").SpecialCells(xlCellTypeConstants)
'ignore the header row
If rng_cell.Row > 2 Then
'use column to get offset count
Dim rng_merge As Range
Set rng_merge = Range(rng_cell, rng_cell.Offset(arr_rows(rng_cell.Column - 1)))
'merge cells
rng_merge.Merge
'apply formatting
If arr_vert_format(rng_cell.Column - 1) Then
'format for the rotated text (columns A:C)
With rng_merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Else
'format for the other cells (column D)
With rng_merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
End With
End If
End If
Next rng_cell
End Sub
Before
After