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
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 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
Consider the following illustrative example
Private Sub drawBorders(listOfBorders)
For Each Item In listOfBorders
With .Borders(Item)
.LineStyle = xlContinious
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
Next Item
End Sub
Sub main()
Dim TopBottom() as Variant
Dim myRange As Range
TopBottom = Array(xlEdgeTop, xlEdgeBottom)
myRange = Range("A1")
With myRange
.value = a
Call DrawBorders(topBottom)
End With
End Sub
I have a sequence of With statements where some of the code is pretty repeating.
I get an error at the DrawBorders sub :
Invalid or unqualified reference
Is it possible to import the reference from the With statement into the Sub?
You should always specify the type of the argument in your Sub or Function.
The error in DrawBordersyou get is because of this With .Borders(Item) which hasn't any object to be referenced to (no With Object before).
My guess is that you wanted to pass the reference inside of your call and that is why you need to pass an object, because the With from the main code won't follow when you call a function or sub!
Here is my proposition for your code :
Private Sub DrawBorders(ListOfBorders As Variant, RangeToFormat As Range)
For Each Item In ListOfBorders
With RangeToFormat.Borders(Item)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
Next Item
End Sub
Sub main()
Dim TopBottom() As Variant, _
Ws As Worksheet, _
MyRange As Range
Set Ws = ActiveSheet
Set MyRange = Ws.Range("A1:J10")
MyRange.Value = A
TopBottom = Array(xlEdgeTop, xlEdgeBottom)
With Ws
Call DrawBorders(TopBottom, .Range("A1:J10"))
End With
'----Or
'Call DrawBorders(TopBottom, MyRange)
End Sub
This should work
Private Sub DrawBorders(listOfBorders() as Variant, r As Range)
For Each Item In listOfBorders
With r.Borders(Item)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
Next Item
End Sub
Dim TopBottom() As Variant
Dim myRange As Range
TopBottom = Array(xlEdgeTop, xlEdgeBottom)
myRange = Range("A1")
With myRange
.Value = a
End With
Call DrawBorders(TopBottom, myRange)
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