How can I count the number of lines in a wrapped cell through vba code?
With Cells(1, 1)
.WrapText = False
height1 = .height
.WrapText = True
height2 = .height
End With
MsgBox height2 / height1 & " Lines"
This code will not work since I have set row height to a fixed one (only one line is visible).
Also in my text, no line breaks since the data is entered through VBA code.
Thanks in advance.
One way would be to subtract the length of the cell with linebreaks removed from the length of the unadjusted cell
Linebreaks can be replaced with a 0 length string using the worksheet function Substitute
Sub test()
Dim c As Range
Set c = ActiveCell
MsgBox Len(c.Value) - Len(Application.WorksheetFunction.Substitute(c.Value, Chr(10), vbNullString)) & " Linebreak(s)"
End Sub
[Update; Not a linebreak!]
As Sid points out in Get first two lines of text from a wraped cell in excel this is tricky if working with font sizes (which can change).
I think the most foolproof way would be to copy the cell contents elsewhere (to an otherwise blank row), and autofit that row based on that cell to get the height.
If you need an approximation :
Sub approx_number_of_lines()
Set Rng = Selection
a = Len(Rng.Value)
'number of line returns
b = Len(Rng.Value) - Len(Application.WorksheetFunction.Substitute(Rng.Value, Chr(10), vbNullString))
c = Rng.ColumnWidth
d = (a / c) + b
'd = WorksheetFunction.Ceiling(a / c, 1) + b
Debug.Print d
End Sub
Related
As part of a larger process I need to create a Excel VBA Macro that read the values from a column and applies basic formatting to the row based on the values in each cell.
The spreadsheet itself is exported from another program and opens directly in Excel. All columns come across formatted as General
The sequence is this:
Start at the second row in Sheet1
Look at Column J
Read the RGB value (which is shown as RGB(X,Y,Z) where X, Y, and Z are the numerical values for the color that needs to be used)
Change that rows text Color for Column A-I to that color
Continue through all rows with text
I found this thread, but I'm not able to make it work.
Any help here much appreciated.
Sub ColorIt()
Set cl = Cells(2, "J")
Do Until cl = ""
txt = cl.Value2
cl.Offset(, -9).Resize(, 9).Font.Color = _
Evaluate("SUMPRODUCT({" & Mid(txt, 5, Len(txt) - 5) & "},{1,256,65536})")
Set cl = cl.Offset(1)
Loop
End Sub
Result:
Edit2
Sub ColorIt2()
Const RGB_COL = "M"
Set cl = Cells(2, RGB_COL)
Do Until cl = ""
txt = cl.Value2
cl.Offset(, 1 - cl.Column).Resize(, cl.Column - 1).Interior.Color = _
Evaluate("SUMPRODUCT({" & Mid(txt, 5, Len(txt) - 5) & "},{1,256,65536})")
Set cl = cl.Offset(1)
Loop
End Sub
Please, use the next function. It will convert the string in a Long color (based on the RGB three parameters. It will work for both caser of comma separators ("," and ", "):
Function ExtractRGB(strRGB As String) As Long
Dim arr: arr = Split(Replace(strRGB, " ", ""), ",")
ExtractRGB = RGB(CLng(Right(arr(0), Len(arr(0)) - 4)), CLng(arr(1)), CLng(left(arr(2), Len(arr(2)) - 1)))
End Function
It can be tested in the next way:
Sub TestExtractRGB()
Dim x As String, color As Long
x = "RGB(100,10,255)"
x = "RGB(100, 10, 255)"
color = ExtractRGB(x)
Debug.Print color
Worksheet("Sheet1").Range("A2:I2").Font.color = color
'or directly:
Worksheet("Sheet1").Range("A2:I2").Font.color = _
ExtractRGB(Worksheet("Sheet1").Range("J2").value)
End Sub
If you comment x = "RGB(100, 10, 255)", it will return the same color valuem for the previous x string...
If you need to do it for all existing rows, the code must iterate from 2 to last Row and you only need to change "A2:I2" with "A" & i & ":I" & i
If necessary, I can show you how to deal with it, but I think is very simple...
I'm developing in VBA Excel and I discovered that I use WorksheetFunction.Trim(Cells(1,1)) where this cells contain any colored element, this element become colored by default.
Here is my code:
Cells(4, 2) = Application.WorksheetFunction.Trim(UCase(Cells(4, 2)))
Did you see this issue before ?
How can I remove blank in the text without this issue ?
Thanks for your help !
For cells with mixed formatting, replacing the cell value will lose the mixed format: instead you need to work with the cell's Characters collection:
Sub tester()
Dim c As Range
For Each c In Range("B3:B10").Cells
TrimAndUppercase c
Next c
End Sub
Sub TrimAndUppercase(c As Range)
Dim i, prevSpace As Boolean
If Len(c.Value) > 0 Then
'trim the ends of the text
Do While Left(c.Value, 1) = " "
c.Characters(1, 1).Text = ""
Loop
Do While Right(c.Value, 1) = " "
c.Characters(Len(c.Value), 1).Text = ""
Loop
'reduce runs of multiple spaces to a single space
For i = c.Characters.Count To 1 Step -1
With c.Characters(i, 1)
If .Text = " " Then
'was the previous character a space?
If prevSpace Then
.Text = "" 'remove this space
Else
prevSpace = True
End If
Else
.Text = UCase(.Text)
prevSpace = False
End If
End With
Next i
End If
End Sub
Note there are some limits to the length of the text using this method, and it can be a little slow with large ranges.
finally, I used this instruction.
Cells(4, 2) = Replace(UCase(Cells(4, 2)), " ", "")
In fact, my cell contain parameters and we perfers to avoid to have blank between them for visibility.
Starting in cell B8, I want to count the number of rows down until we hit a cell that is filled with the RGB 93, 123, 157.
I tried using the autofill formula feature while recording, but the cell references stayed absolute: Selection.AutoFill Destination:=ActiveCell.Range("A1:A182")
This will only work if the report has 182 rows, which they won't all have.
I was also given this to try:
Sub Test()
Dim i As Long, bluerow As Long
For i = 1 To 10000
If Cells(i, 2).Interior.Color = RGB(93, 123, 157) Then
bluerow = i
Exit For
End If
Next i
Range("B6").AutoFill Destination:=Range("B6:B" & bluerow), Type:=xlFillDefault
End Sub
But it doesn't put any numbers in column B.
This could work by itself.
Sub NumRws()
'"Cells(5, 2)" is a reference to B5(for some reason, shouldn't it be B8? in that case it should say "Cells(8, 2)")
'"Cells(Rows.Count, 1).End(xlUp)" refers to the last used cell(a cell with any value) in column A
'".Offset(-1, 1)" offsets the second reference to column B and now also one row up("-1,")
'..and "Range(...)" combines the two
'".FormulaR1C1 = "=ROW()-4"" applies the formula which results in row number minus 4(if you change to B8 it should be -7)
Range(Cells(5, 2), Cells(Rows.Count, 1).End(xlUp).Offset(-1, 1)).FormulaR1C1 = "=ROW()-4"
'..Also if you just want the result of the formula do the following instead
With Range(Cells(5, 2), Cells(Rows.Count, 1).End(xlUp).Offset(-1, 1))
.FormulaR1C1 = "=ROW()-4"
.Value = .Value
End With
End Sub
The code below uses Find to get the first cell in column B that matches the color criteria, and then subtracts 7 from the row number.
Sub FindtheFirstColoredCellCountRowsfromRow8()
'Find the first cell in Column(2) with specific interior color and count number of rows
Dim fndCel As Range, cnt As Long
ActiveCell.Interior.Color = RGB(93, 123, 157) 'colors any cell to use in "Find"
Application.FindFormat.Interior.Color = ActiveCell.Interior.Color 'store cell color in find
'set the find range variable to find the first cell that matches the color in Column B
Set fndCel = ActiveSheet.Columns(2).Find("", , , , , xlNext, , , True)
cnt = fndCel.Row - 7 'set the count variable by subtracting 7 from the fndCell row
MsgBox cnt
Application.FindFormat.Clear 'reset FindFormat
ActiveCell.Interior.Color = xlNone 'clear the cell you used to set the color to find
End Sub
Not exactly sure what you're asking for? You want the row number to appear on every cell from B8 till the row where it appears? in that case use:
range("B8:B" & bluerow) = bluerow
This will type the row number where the RGB value is found, starting from B8, down to where the RGB was found. If this is not what you need please explain your problem further.
EDIT: Oh, my bad. Then use this:
For i = 1 To 10000
If Cells(7 + i, 2).Interior.Color = RGB(93, 123, 157) Then
Exit For
Else
Cells(7 + i, 2) = i
End If
Next i
I would suggest finding the last row, though, instead of using "to 10000", you can use:
LastRow = cells(rows.count,2).end(xlup).row
I have a problem where I can't add numbers with decimals. Only numbers with no decimals.
I have written a code to sum up values from different cells. This work fine as long as the numbers are without decimals.
Here is my code:
Sub SumValues()
'This makro is made to add values together depending on
'x amount of Sheets in the workbook:
Application.ScreenUpdating = False
'A will sum up the values from each cell,
'depending on the amount of Sheets in the this Workbook:
A = 0
For I = 1 To ThisWorkbook.Sheets.Count
'Adding the values from cell E5 to Cells(5, 5 + (I - 1) * 3),
'with the distance 3 between each cell:
A = A + Cells(5, 5 + (I - 1) * 3)
Next I
'The values A that is added togheter from the cells, is now put in a cell:
Worksheets("Sheet1").Cells(1, 1).Formula = "=" & A & ""
Application.ScreenUpdating = True
End Sub
So for 3 number of sheets, "I" goes from 1 to 3.
So if my cells contain these numbers:
Cell(5,5) = 2
Cell(5,8) = 3
Cell(5,11) = 8
I get the sum in Cell(1,1) = 13
But if I have these values:
Cell(5,5) = 2,2
Cell(5,8) = 3
Cell(5,11) = 8
I get the "run-time error '9': Subscript out of range" Error message when running script.
Any suggestions?
Another question is if it is possible to get the formula into the cell I am adding up the values?
For Examlpe if I have 3 Sheets in my Workbook, it will sum up the values from Cell(5,5) , Cell(5,8) and Cell(5,11).
The sum is shown in Cell(1,1).
But all I get is the number, not the formula.
Is it possible to make the Cell show the formula "=E5+H5+K5"?
This last question might be a "fix" for the first question, if it is the separator "," that is making trouble, maybe?
Thanks
GingerBoy
Tested and working fine
Declare your variables
You need to qualify your objects with a worksheet
No need to toggle off Screen Updating here. You are just modifying one cell
This code will place the Value in A1 and the Formula in B1
Disclaimer:
Your code, and the code below, is subject to a potential Type Mismatch Error if you feed any cell with a non-numerical value into your loop. If there is some chance of any non-numerical cell being in the sum range, you can avoid the error by nesting something like the following inside your loop: If ISNUMERIC(Range) Then.
Sub SumValues()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim A As Double, i As Long, Loc As String
For i = 1 To ThisWorkbook.Sheets.Count
A = A + ws.Cells(5, (5 + (i - 1) * 3))
Loc = ws.Cells(5, (5 + (i - 1) * 3)).Address(False, False) & "+" & Loc
Next i
ws.Range("A1") = A
ws.Range("B1").Formula = "=" & Mid(Loc, 1, Len(Loc) - 1)
End Sub
Due to beginner for VBA, I am in a difficult to find this codes.
I need to create 'Command Button' to insert formula according to
current cell location.
Eg. If current cell location is S7, need to get formula in to it '=K7*L7'.
Current cell location change all the time. Multiplication of Column K and L fixed.
Please help me to write this codes.
You can assign below code to command button
Sub Insert_Formula
n = Selection.row
Selection.Value = "=K" & n & "*L" & n
End Sub
In VBA, Selection will get the selected cell properties.
For example, if you select S7,
n = Selection.Row
Then n will be 7
Selection.Value = "=K" & n & "*L" & n
Above will set selected cell's formulat to =K7*L7
In addition, if you want the button to work on selected range which is more than one cell,
Private Insert_Formula_Multi_Cells
For X = 1 To Selection.Rows.Count
n = Selection.Row + X - 1
Selection.Range(Cells(X, 1), Cells(X, Selection.Columns.Count)) = "=K" & n & "*L" & n
Next X
End Sub
Selection.Rows.Count Gets number of rows selected.
Selection.Columns.Count gets number of columns selected
to get current location in excel you can use ActiveCell.Address command.
Below code first gets current selected cells address and then multiplies with K(11) and L(12) columns to print value in active cell.
Sub acell()
Dim s As String
s = ActiveCell.Address
Range(s).Select
Range(s).Value2 = Cells(2, 11) * Cells(2, 12)
Debug.Print s
End Sub
You can add them in loop as per your requirement.