Option Explicit
Sub count_caracters_in_cell()
'Erik Van Geit
'061019
Dim cell As Range
Dim nr As Variant
Dim x As Integer
Dim temp As String
Set cell = Sheets(1).Range("A1")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do
nr = Application.InputBox("fill in number of caracters to be tested (20,30,...,3000,...)", "# caracters to be put in one cell ", 1)
If nr = False Then GoTo skip
If nr Mod 10 <> 0 Or nr < 20 Then MsgBox "only numbers ending with 0 and > 10 ", 48, "20,30,..."
Loop While nr Mod 10 <> 0 Or nr < 20
With cell
.EntireColumn.ColumnWidth = 120
.RowHeight = 350
.WrapText = True
.Font.Size = 4 'change to test
.VerticalAlignment = xlVAlignTop
.Offset(1, 0).FormulaR1C1 = "=LEFT(R[-1]C,10) & "" "" & RIGHT(R[-1]C,10)"
.Offset(2, 0).FormulaR1C1 = "=LEN(R[-2]C)"
.Offset(3, 0) = "blue = 10, green = 100, red = 1000"
.Offset(1, 0).Select
End With
'temp = temp & Application.Rept("o", (nr - 20))
temp = "STARTooooo" & Application.Rept("o", (nr - 20)) & "oooooooEND"
cell = temp
If nr < 2000 Then
For x = 10 To nr Step 10
With cell.Characters(Start:=x, Length:=1).Font
.Size = 10
.ColorIndex = 8
End With
Next x
End If
For x = 100 To nr Step 100
With cell.Characters(Start:=x, Length:=1).Font
.Size = 11
.ColorIndex = 4
End With
Next x
For x = 1000 To nr Step 1000
With cell.Characters(Start:=x, Length:=1).Font
.Size = 12
.ColorIndex = 3
End With
Next x
With ActiveWindow
.DisplayHeadings = False
.Zoom = True
.ScrollRow = 1
.ScrollColumn = 1
End With
MsgBox "number of caracters put in the cell: " & " " & Len(temp) & Chr(10) & _
"number of caracters counted in the cell: " & " " & Len(cell) & Chr(10) & _
"""START"" at the beginning & ""END"" at the end to test if everything resides in memory" & Chr(10) & _
"in the cell below please find the first 10 & last 10 caracters found in cell A1", 64, "caracters"
skip:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayScrollBars = False
End With
End Sub