characters object limit

[Batailleye]

Hello,

Is there a way to have more than 256 text characters per cell? I'm
writing a macro that uses the characters object, and that works with
strings that are shorter than 256 characters. Every time I have more
than 256 characters, I get a run-time error. It says "Runtime Error
'1004' Unable to set the text property to the characters class." I'm
using Excel 2000. My code is:

Do While i < c.Characters.Count + m
If c.Characters(i, 1).Text = Chr(34) And x Mod 2 >
0 Then
c.Characters(i, 1).Text = "“"
x = x + 1
i = i + 6
ElseIf c.Characters(i, 1).Text = Chr(34) And x Mod
2 = 0 Then
c.Characters(i, 1).Text = "”"
x = x + 1
i = i + 6
Else
c.Characters(i, 1).Text = c.Characters(i,
1).Text
i = i + 1
End If

Loop

Thank you

 

[Jim Cone]

You can replace text characters using the Mid "Statement".

Sub MoreTextStuff()
Dim strOld As String
strOld = Range("B5").Text
Mid$(strOld, 300, 5) = "stuff"
Range("B5").Value = strOld
End Sub
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware



"Batailleye" <[email protected]>
wrote in message
Hello,
Is there a way to have more than 256 text characters per cell? I'm
writing a macro that uses the characters object, and that works with
strings that are shorter than 256 characters. Every time I have more
than 256 characters, I get a run-time error. It says "Runtime Error
'1004' Unable to set the text property to the characters class." I'm
using Excel 2000. My code is:

Do While i < c.Characters.Count + m
If c.Characters(i, 1).Text = Chr(34) And x Mod 2 > 0 Then
c.Characters(i, 1).Text = "“"
x = x + 1
i = i + 6
ElseIf c.Characters(i, 1).Text = Chr(34) And x Mod 2 = 0 Then
c.Characters(i, 1).Text = "”"
x = x + 1
i = i + 6
Else
c.Characters(i, 1).Text = c.Characters(i, 1).Text
i = i + 1
End If
Loop
Thank you

 

[Batailleye]

You can replace text characters using the Mid "Statement".

Sub MoreTextStuff()
Dim strOld As String
strOld = Range("B5").Text
Mid$(strOld, 300, 5) = "stuff"
Range("B5").Value = strOld
End Sub
--
Jim Cone
San Francisco, USAhttp://www.realezsites.com/bus/primitivesoftware

"Batailleye" <[email protected]>
wrote in message
Hello,
Is there a way to have more than 256 text characters per cell? I'm
writing a macro that uses the characters object, and that works with
strings that are shorter than 256 characters. Every time I have more
than 256 characters, I get a run-time error. It says "Runtime Error
'1004' Unable to set the text property to the characters class." I'm
using Excel 2000. My code is:

Do While i < c.Characters.Count + m
If c.Characters(i, 1).Text = Chr(34) And x Mod 2 > 0 Then
c.Characters(i, 1).Text = "“"
x = x + 1
i = i + 6
ElseIf c.Characters(i, 1).Text = Chr(34) And x Mod 2 = 0 Then
c.Characters(i, 1).Text = "”"
x = x + 1
i = i + 6
Else
c.Characters(i, 1).Text = c.Characters(i, 1).Text
i = i + 1
End If
Loop
Thank you

Jim,

Thanks for your reply. The problem I run into when I use a variable
to store the cell's text is that I lose the text's formatting. In
this particular case, the first character is a superscript. When I
run a macro storing the text in a variable, all the text becomes
superscript.

 

[Dave Peterson]

If all you have to worry about is that first character being a superscript, then
I'd just change the string and format that initial character when you're done.

But if you have to worry about all the characters and all the formatting, I
think the process gets much more complex (pronounced slow!).

Here's what I did when I wanted to change a substring to a different length
substring, but keep each the formatting for each character in the cell. Maybe
it'll give you an idea:

Option Explicit
Option Compare Text

Type myCharacter
myChar As String
myLen As Long
myName As String
myFontStyle As String
mySize As Double
myStrikethrough As Boolean
mySuperscript As Boolean
mySubscript As Boolean
myOutlineFont As Boolean
myShadow As Boolean
myUnderline As Long
myColorIndex As Long
End Type
Sub testme()

Application.ScreenUpdating = False

Dim myWords As Variant
Dim myNewWords As Variant
Dim myRng As Range
Dim foundCell As Range
Dim iCtr As Long 'word counter
Dim lCtr As Long 'length of string counter
Dim cCtr As Long 'character counter
Dim usedChars As Long
Dim FirstAddress As String
Dim AllFoundCells As Range
Dim myCell As Range
Dim myStr As String
Dim myCharacters() As myCharacter

myWords = Array(Chr(34))
myNewWords = Array("“")

Set myRng = Selection

On Error Resume Next
Set myRng = Intersect(myRng, _
myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
On Error GoTo 0

If myRng Is Nothing Then
MsgBox "Please choose a range that contains text constants!"
Exit Sub
End If

For iCtr = LBound(myWords) To UBound(myWords)
FirstAddress = ""
Set foundCell = Nothing
With myRng
Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart, _
after:=.Cells(.Cells.Count))

If foundCell Is Nothing Then
MsgBox myWords(iCtr) & " wasn't found!"
Else
Set AllFoundCells = foundCell
FirstAddress = foundCell.Address
Do
If AllFoundCells Is Nothing Then
Set AllFoundCells = foundCell
Else
Set AllFoundCells = Union(foundCell, AllFoundCells)
End If
Set foundCell = .FindNext(foundCell)

Loop While Not foundCell Is Nothing _
And foundCell.Address <> FirstAddress
End If

End With

If AllFoundCells Is Nothing Then
'do nothing
Else
For Each myCell In AllFoundCells.Cells
ReDim myCharacters(1 To Len(myCell.Value))
usedChars = 0
cCtr = 1
lCtr = 0
Do
usedChars = usedChars + 1
With myCell.Characters(cCtr, 1)
myCharacters(usedChars).myName = .Font.Name
myCharacters(usedChars).myFontStyle = .Font.FontStyle
myCharacters(usedChars).mySize = .Font.Size
myCharacters(usedChars).myStrikethrough _
= .Font.Strikethrough
myCharacters(usedChars).mySuperscript _
= .Font.Superscript
myCharacters(usedChars).mySubscript = .Font.Subscript
myCharacters(usedChars).myOutlineFont _
= .Font.OutlineFont
myCharacters(usedChars).myShadow = .Font.Shadow
myCharacters(usedChars).myUnderline = .Font.Underline
myCharacters(usedChars).myColorIndex = .Font.ColorIndex

If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _
= myWords(iCtr) Then
myCharacters(usedChars).myChar = myNewWords(iCtr)
myCharacters(usedChars).myLen _
= Len(myNewWords(iCtr))
cCtr = cCtr + Len(myWords(iCtr))
lCtr = lCtr + Len(myNewWords(iCtr))
Else
myCharacters(usedChars).myChar _
= Mid(myCell.Value, cCtr, 1)
myCharacters(usedChars).myLen = 1
cCtr = cCtr + 1
lCtr = lCtr + 1
End If
If cCtr > Len(myCell.Value) Then Exit Do
End With
Loop

myStr = Space(lCtr)
lCtr = 1
For cCtr = 1 To usedChars
Mid(myStr, lCtr, myCharacters(cCtr).myLen) _
= myCharacters(cCtr).myChar
lCtr = lCtr + myCharacters(cCtr).myLen
Next cCtr
myCell.Value = myStr
cCtr = 1
lCtr = 1
Do
With myCell.Characters(lCtr, myCharacters(cCtr).myLen)
.Font.Name = myCharacters(cCtr).myName
.Font.FontStyle = myCharacters(cCtr).myFontStyle
.Font.Size = myCharacters(cCtr).mySize
.Font.Strikethrough _
= myCharacters(cCtr).myStrikethrough
.Font.Superscript = myCharacters(cCtr).mySuperscript
.Font.Subscript = myCharacters(cCtr).mySubscript
.Font.OutlineFont = myCharacters(cCtr).myOutlineFont
.Font.Shadow = myCharacters(cCtr).myShadow
.Font.Underline = myCharacters(cCtr).myUnderline
.Font.ColorIndex = myCharacters(cCtr).myColorIndex
End With
lCtr = lCtr + myCharacters(cCtr).myLen
cCtr = cCtr + 1
If lCtr > Len(myStr) Then
Exit Do
End If
Loop
Next myCell
End If
Next iCtr

Application.ScreenUpdating = True

End Sub

====
You'll have to add the logic to change each of the double quotes to what you
want, though.

 

[Batailleye]

If all you have to worry about is that first character being a superscript, then
I'd just change the string and format that initial character when you're done.

But if you have to worry about all the characters and all the formatting, I
think the process gets much more complex (pronounced slow!).

Here's what I did when I wanted to change a substring to a different length
substring, but keep each the formatting for each character in the cell. Maybe
it'll give you an idea:

Option Explicit
Option Compare Text

Type myCharacter
myChar As String
myLen As Long
myName As String
myFontStyle As String
mySize As Double
myStrikethrough As Boolean
mySuperscript As Boolean
mySubscript As Boolean
myOutlineFont As Boolean
myShadow As Boolean
myUnderline As Long
myColorIndex As Long
End Type
Sub testme()

Application.ScreenUpdating = False

Dim myWords As Variant
Dim myNewWords As Variant
Dim myRng As Range
Dim foundCell As Range
Dim iCtr As Long 'word counter
Dim lCtr As Long 'length of string counter
Dim cCtr As Long 'character counter
Dim usedChars As Long
Dim FirstAddress As String
Dim AllFoundCells As Range
Dim myCell As Range
Dim myStr As String
Dim myCharacters() As myCharacter

myWords = Array(Chr(34))
myNewWords = Array("“")

Set myRng = Selection

On Error Resume Next
Set myRng = Intersect(myRng, _
myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
On Error GoTo 0

If myRng Is Nothing Then
MsgBox "Please choose a range that contains text constants!"
Exit Sub
End If

For iCtr = LBound(myWords) To UBound(myWords)
FirstAddress = ""
Set foundCell = Nothing
With myRng
Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart, _
after:=.Cells(.Cells.Count))

If foundCell Is Nothing Then
MsgBox myWords(iCtr) & " wasn't found!"
Else
Set AllFoundCells = foundCell
FirstAddress = foundCell.Address
Do
If AllFoundCells Is Nothing Then
Set AllFoundCells = foundCell
Else
Set AllFoundCells = Union(foundCell, AllFoundCells)
End If
Set foundCell = .FindNext(foundCell)

Loop While Not foundCell Is Nothing _
And foundCell.Address <> FirstAddress
End If

End With

If AllFoundCells Is Nothing Then
'do nothing
Else
For Each myCell In AllFoundCells.Cells
ReDim myCharacters(1 To Len(myCell.Value))
usedChars = 0
cCtr = 1
lCtr = 0
Do
usedChars = usedChars + 1
With myCell.Characters(cCtr, 1)
myCharacters(usedChars).myName = .Font.Name
myCharacters(usedChars).myFontStyle = .Font.FontStyle
myCharacters(usedChars).mySize = .Font.Size
myCharacters(usedChars).myStrikethrough _
= .Font.Strikethrough
myCharacters(usedChars).mySuperscript _
= .Font.Superscript
myCharacters(usedChars).mySubscript = .Font.Subscript
myCharacters(usedChars).myOutlineFont _
= .Font.OutlineFont
myCharacters(usedChars).myShadow = .Font.Shadow
myCharacters(usedChars).myUnderline = .Font.Underline
myCharacters(usedChars).myColorIndex = .Font.ColorIndex

If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _
= myWords(iCtr) Then
myCharacters(usedChars).myChar = myNewWords(iCtr)
myCharacters(usedChars).myLen _
= Len(myNewWords(iCtr))
cCtr = cCtr + Len(myWords(iCtr))
lCtr = lCtr + Len(myNewWords(iCtr))
Else
myCharacters(usedChars).myChar _
= Mid(myCell.Value, cCtr, 1)
myCharacters(usedChars).myLen = 1
cCtr = cCtr + 1
lCtr = lCtr + 1
End If
If cCtr > Len(myCell.Value) Then Exit Do
End With
Loop

myStr = Space(lCtr)
lCtr = 1
For cCtr = 1 To usedChars
Mid(myStr, lCtr, myCharacters(cCtr).myLen) _
= myCharacters(cCtr).myChar
lCtr = lCtr + myCharacters(cCtr).myLen
Next cCtr
myCell.Value = myStr
cCtr = 1
lCtr = 1
Do
With myCell.Characters(lCtr, myCharacters(cCtr).myLen)
.Font.Name = myCharacters(cCtr).myName
.Font.FontStyle = myCharacters(cCtr).myFontStyle
.Font.Size = myCharacters(cCtr).mySize
.Font.Strikethrough _
= myCharacters(cCtr).myStrikethrough
.Font.Superscript = myCharacters(cCtr).mySuperscript
.Font.Subscript = myCharacters(cCtr).mySubscript
.Font.OutlineFont = myCharacters(cCtr).myOutlineFont
.Font.Shadow = myCharacters(cCtr).myShadow
.Font.Underline = myCharacters(cCtr).myUnderline
.Font.ColorIndex = myCharacters(cCtr).myColorIndex
End With
lCtr = lCtr + myCharacters(cCtr).myLen
cCtr = cCtr + 1
If lCtr > Len(myStr) Then
Exit Do
End If
Loop
Next myCell
End If
Next iCtr

Application.ScreenUpdating = True

End Sub

====
You'll have to add the logic to change each of the double quotes to what you
want, though.

Dave,

I don't know how to thank you! It really works! Thank you so much.