I have a worksheet with merged cells (e.g. B2:C3 with value "myValue"). If I try to search for a value which is in a merged cell with
r = ThisWorkbook.ActiveWorksheets.Range("$A:$D").Find("myValue")
Debug.Print r.Address
I only get the address of other single cells with similar values but not of the merged cell.
How can I do this with VBA? If I use the manual search function of Excel it finds the value in no time.
Best regards,
Harry
EDIT: When I use the code from Gary I get a runtime error 91. The variable r is Nothing.
Cleaning up a few things:
Sub MAIN()
Dim r As Range
Call Setup
Set r = ThisWorkbook.ActiveSheet.Range("$A:$D").Find("myValue")
Debug.Print r.Address
End Sub
Sub Setup()
Dim rng As Range
Set rng = Range("B2:C3")
With rng
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
rng.Value = "MyValue"
End Sub
Will get you the upper left-hand corner of the merged area:
you should use MergeArea for such cases:
Sub test()
Dim r As Range
Set r = ThisWorkbook.ActiveSheet.[A:D].Find("myValue")
Debug.Print r.MergeArea.Address
End Sub
Related
I have an AutoFitMergedCellRowHeight subroutine that takes a merged cell as an argument and then fixes its height so that all the text will be visible. The FixAll sub is activated when a button is pressed.
The problem is it's behavior is unstable. When a cell is selected that is in the same column as the merged cell (column 4) the height is one size (smaller, but the text is 100% visible); when a cell is selected outside that column but inside a table nothing happens; when a cell is selected outside the table the height is fixed but get too big.
Why is this happening? I can't see anything related to a selected cell in the sub.
Sub FitAll()
AutoFitMergedCellRowHeight (Cells(3, 4))
End Sub
Sub AutoFitMergedCellRowHeight(cell As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If cell.MergeCells Then
With cell.MergeArea
.WrapText = True
If .Rows.Count = 1 Then
cell = cell.MergeArea.Cells(1, 1)
MsgBox (cell.Row & "and" & cell.Column)
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = cell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth +
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub
EDIT: I compare my results also to the same sub that doesn't use an argument but rather a selected cell. The results differ thought even after applying the changes CLR suggested..
Sub AutoFitMergedActiveCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
.WrapText = True
If .Rows.Count = 1 Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
'MsgBox ("DONE")
MsgBox (ActiveCell.Row & "and" & ActiveCell.Column)
End Sub
For Each CurrCell In Selection is looking at selected cell, not cell passed in parameter.
I think you want to replace:
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
with something like:
For Each CurrCell In cell.MergeArea
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
My script moves data to excel template. Codewords is changed for relevant info.
All works well if TPLNR and AUFNR is filled. The cell is two rows in height. But if i leave AUFNR or TPLNR blank - cell height not ajusted. This is macro used to fill and adjust every row in table.
Sub Mac1()
'
' Mac1
'
Dim i As Integer
i = 12
'
Do While Range("L" & i).Value <> "THE END"
If Range("L" & i).Value = "M" Then
...
ElseIf Range("L" & i).Value = "T" Then
Range("A" & i & ":D" & i).Select
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.WrapText = True
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Font.Italic = True
End If
i = i + 1
Loop
Call AutoFitMergedCellRowHeight
Columns("L:L").Select
Selection.Delete Shift:=xlToLeft
End Sub
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
Dim a() As String, isect As Range, i
'Take a note of current active cell
Set StartCell = ActiveCell
'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
With c.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
If MergeRng Is Nothing Then
Set MergeRng = c.MergeArea
ReDim a(0)
a(0) = c.MergeArea.Address
Else
Set isect = Intersect(c, MergeRng)
If isect Is Nothing Then
Set MergeRng = Union(MergeRng, c.MergeArea)
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = c.MergeArea.Address
End If
End If
End If
End With
End If
Next c
Application.ScreenUpdating = False
'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
'Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
MergedCellRgWidth = 0
Next i
StartCell.Select
Application.ScreenUpdating = True
'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing
End Sub
What could i do to get rows after 12 to look like it intended to? With 1x height.
Making the rows equal size is quite a standard VBA task.
Just try to put this logic away from your code. The only 3 things you should know is the starting row, the ending row and the size. Thus, you may be able to do it quite well. In the code below change the parameters of Call AllRowsAreEqual(4, 10, 35) in order to make it work for you.
Option Explicit
Sub AllRowsAreEqual(lngStartRow As Long, lngEndRow As Long, lngSize)
Dim lngCounter As Long
For lngCounter = lngStartRow To lngEndRow
Cells(lngCounter, 1).RowHeight = lngSize
'Debug.Print lngCounter
Next lngCounter
End Sub
Public Sub Main()
Call AllRowsAreEqual(4, 10, 35)
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 keep getitng this Error "Type missmatch"
I want to be able to format cells in my spreed sheet by passing a range and a value I'd like displayed.
Can anyone point out where I'm going wrong?
Sub Layout()
Call Create_Box("A1:A2", 10)
End Sub
Sub Create_Box(R As Range, V As String)
Dim box As Object
Set box = Range(R)
With box
.Merge
.Value = Box_value
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Border.Style = continous
.Border.Color = black
.Border.Weight = xlThick
End With
End Sub`
The parameter you are passing in is not a Range object; just a string represenfting a range object's local Address property.
Sub Layout()
with activesheet '<-set this explicitly to something like With Sheets("Sheet1")
Call Create_Box(.range("A1:A2"), 10)
end with
End Sub
Sub Create_Box(R As Range, V As String)
With R
.Merge
.Value = Box_value
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Border.Style = xlContinuous
.Border.Color = 0
.Border.Weight = xlThick
End With
End Sub
This should do it:
Sub Create_Box(R As String, V As String)
Pass it as a range object.
Sub Layout()
Dim r1 As Range
Dim ws As Excel.Worksheet
Set ws = Application.ActiveSheet
Set r1 = ws.Range("A1:A2")
Call Create_Box(r1, "10")
End Sub
Sub Create_Box(R As Range, V As String)
Dim box As Object
Set box = Range(R.Address)
With box
.Merge
.Value = Box_value
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Border.Style = continous
.Border.Color = black
.Border.Weight = xlThick
End With
End Sub
I have written this code to merge a few lines in each column, from column C to AZ.
For some reason the range does not match the one I was expecting, in this case the code merges the cells C8:C10 then D8:D12, E8:E12, and so on. lines = 2 in this example.
I don't understand why aren't the ranges matching if lines value is not changing inside the for.
Thanks!
For columns = 0 To 49
Range(Range("C8").Offset(0, columns), Range("C8").Offset((lines), columns)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
next comlumns
Columns is a reserved word. And you said that this code did run?
If I change that to a valid variable then the code runs. The problem is the way you are using Offset
?[C8].offset(2).address after the way you merge will give you $C$12
Also avoid the use of .Select INTERESTING READ And not to mention fully qualify your objects. For example your range and cell objects are not fully qualified and may give you error.
I think, this is what you are trying to achieve?
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim i As Long, rw As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
rw = 2
With ws
For i = 3 To 52
Set rng = .Range(.Cells(8, i), .Cells(8 + rw, i))
With rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next i
End With
End Sub