Replies

John, How about this version.
First put this at the top of the module to contain the sub that follows:

 
Private Type KeyboardBytes
    kbByte(0 To 255) As Byte
End Type

Dim kbArray As KeyboardBytes

Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Long
Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long

Const VK_NUMLOCK As Integer = &H90
Const VK_SHIFT As Integer = &H10
Const VK_CONTROL As Integer = &H11
Const VK_MENU As Integer = &H12 'Alt key
Const VK_CAPSLOCK As Integer = &H14

Now here’s the sub. Attach it to a button and run it this way. Hold down control & shift and click the button to get $A$1, just the control key and click gives $A1, just the shift key and click gives A$1, and just a plain click gives A1.

Sub RefSwitcher()
Dim ShiftState As Long
Dim CntrlState As Long

ShiftState = GetKeyState(VK_SHIFT) And 128
CntrlState = GetKeyState(VK_CONTROL) And 128
If ShiftState = 128 And CntrlState = 128 Then
    With Selection
        .Formula = Application.ConvertFormula(Formula:=.Formula, _
        fromreferencestyle:=xlA1, toreferencestyle:=xlA1, toabsolute:=xlAbsolute)
    End With
ElseIf CntrlState = 128 Then
    With Selection
        .Formula = Application.ConvertFormula(Formula:=.Formula, _
        fromreferencestyle:=xlA1, toreferencestyle:=xlA1, toabsolute:=xlRelRowAbsColumn)
    End With
ElseIf ShiftState = 128 Then
    With Selection
        .Formula = Application.ConvertFormula(Formula:=.Formula, _
        fromreferencestyle:=xlA1, toreferencestyle:=xlA1, toabsolute:=xlAbsRowRelColumn)
    End With
Else
    With Selection
        .Formula = Application.ConvertFormula(Formula:=.Formula, _
        fromreferencestyle:=xlA1, toreferencestyle:=xlA1, toabsolute:=xlRelative)
    End With
End If
End Sub

Ken

Jan,

Nope, no command button. I’m running it from the Macro dialog box, and also from a custom menu button.

Ken

Legare & Jan,

Yes, the cancel button does give me that error too, but so does the OK button. I probably need to reinstall XL to fix this, but I’m not sure that it is worth the effort required. Thanks for your help.

Ken

Legare, Thanks for responding. Here’s my actual project…although I have the same problem with the snippet as with the actual project.
It’s purpose is to extract the unique values from a selected 1 column list and write it to the target location. The error occurs on the
“Set” statement.

Public Sub Extract()
Dim rngStartingCell As Range

Set rngStartingCell = Application.InputBox(Prompt:="Select a cell in a blank area _
 to start the list of unique items", Type:=8)

Selection.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:="", _
CopyToRange:=rngStartingCell, Unique:=True

End Sub 

Ronny,

Take a look at this macro which was written to help create math equations in Excel It uses special code characters in your equation to convert text to super, sub, italic, or characters from the Symbol font. You could probably customize it to suit your needs.

http://www.wopr.com/cgi-bin/w3t/showthread…amp;Main=128269%5B/url%5D

As it stands it doesn’t run on cells with formulas. but if you disable that line it will run and convert the formula to a value.

Regards
Ken

Take a look at this Chip Pearson page. Look for the heading

Double Lookups

Alan,

I’ve been experiencing the same difficultly when pasting from other applications. If I’ve used the TextToColumns wizard and identified a delimiter, any subsequent pastes continue to use it as a delimiter.

Here’s a little macro that I wrote to “reset” the delimiters to nulls. Just attach it to a button, select the cell you want to paste to, run the macro, then paste away.

Sub ResetTextPaste()
'
    Dim strAddress As String
    ActiveCell.Value = " "
    strAddress = ActiveCell.Address
    Selection.TextToColumns Destination:=Range(strAddress), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1)
    ActiveCell.Value = ""
End Sub

For those who may be wondering what this is about, this is for when the Paste|Special option gives you these choices: BIFF format, SYLK format, HTML format, Unicode Format or Text format…and you want either Unicode Text or Text Format.

Kevin,

I thought this would be an interesting project, but Jan had a solution before I had a chance to try anything. Anyway, since you still needed an improvement to the code, I (borrowing liberally from Jan ) wrote this code which should detect and format all instances of a pair of formatting codes.

Sub MyAttempt()
Dim iChar() As Long
Dim sCodeChar As String
Dim sTestChar As String
Dim sWork As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim Index As Long
Dim TextLength As Long
Dim bFlag As Boolean
Const sChars As String = "_^%&#"

If Left(ActiveCell.Formula, 1) = "=" Then Exit Sub

'Find number of pairs of formatting codes and redim array
TextLength = Len(ActiveCell.Value)
For i = 1 To TextLength
    If InStr(sChars, Mid(ActiveCell.Value, i, 1)) > 0 Then j = j + 1
Next i
If j  2  j / 2 Then
    MsgBox "Code pair is incomplete. Halt formatting procedure"
    Exit Sub
End If
j = j / 2 + 1
ReDim iChar(j, 3)

Index = 1  'initialize

'loop through each formatting character
For i = 1 To 5
    'remove all code chars except the relevant code character from text string
    'i is the index number for the formatting code
    sWork = ""
    sCodeChar = Mid(sChars, i, 1)
    For j = 1 To TextLength
        sTestChar = Mid(ActiveCell.Value, j, 1)
        If InStr(sChars, sTestChar) = 0 Then 'the char is not a formatting char
            sWork = sWork + sTestChar
        ElseIf sTestChar = sCodeChar Then  'the char is the relevant formatting char
            sWork = sWork + sTestChar
        End If
    Next j
    
    'Save the starting and ending positions for each actual segment of text to
    'be formatted and the formating character's index.  Use k to count the instances
    'of the formatting character.
    k = 0
    For j = 1 To Len(sWork)
        If Mid(sWork, j, 1) = sCodeChar Then
            If Not bFlag Then 'First instance in a pair of codes
                iChar(Index, 1) = j - k
                bFlag = True
                k = k + 1
            Else              'Second instance in a pair of codes
                iChar(Index, 2) = j - k - 1
                bFlag = False
                k = k + 1
                iChar(Index, 3) = i
                Index = Index + 1
            End If
        End If
    Next j
Next i

'Remove all formatting characters from active cell contents
sWork = ""
For i = 1 To Len(ActiveCell.Value)
    If InStr(sChars, Mid(ActiveCell.Value, i, 1)) = 0 Then
        sWork = sWork + Mid(ActiveCell.Value, i, 1)
    End If
Next i
ActiveCell.Value = sWork

'Apply formatting
For i = 1 To Index - 1
    With ActiveCell.Characters(iChar(i, 1), iChar(i, 2) - iChar(i, 1) + 1)
        Select Case iChar(i, 3)
            Case 1 ' Underscore
                .Font.Subscript = True
            Case 2 ' ^
                .Font.Superscript = True
            Case 3 ' %
                .Font.Italic = True
            Case 4 ' & fixed per JohnBF
                .Font.Bold = True
            Case 5 ' # Greek
                .Font.Name = "Symbol"
         End Select
    End With
Next i

End Sub

Sorry, but the “next step” is beyond my knowledge. Perhaps Jan, a true excel guru, can help.

– edited –
What you might consider is keeping a copy of the original formula with the formatting codes in a nearby cell and modify that cell with your new term, copy to the desired location and run the macro, then.

Ken

Copy Page Setup Instructions

Here’s a link to Chip Pearsons Site decribing how to do this:

Extracting Unique Entries

One way to do this is:
1) open your address book
2) in the main window, right click on the group
3) choose Action|Send Mail

A new email message appears with the individual addresses in the To: box rather than the list name.

HTH

Assuming your column of numbers starts in A1 and has no blanks except after the last number, you can use this formula to average the last five numbers in the column:

=AVERAGE(OFFSET($A$1,COUNT($A:$A)-5,0,5,1))

HTH

Wassim

I like to build complex formulas first in multiple cells as you suggest. But then I use the following macro to do my “nesting” for me.

I’ve used it on and off for a while and it works fine, but it hasn’t been fully tested, so it may break under some circumstances. I’m sure others can write more elegant code, but I’ve not noticed anything like this on the board. I’m sure others more expert could improve it and make it unbreakable.

Sub ReferenceReplace()
Dim RefMaster As Range
Dim RefServant As Range
Dim MasterFormula As String
Dim ServantFormula As String
Dim Work As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim x As Long
Dim y As Long
Dim NotFound As Boolean

On Error GoTo Cancelled

Set RefMaster = Application.InputBox("Select the cell containing the master formula", Type:=8)
Set RefServant = Application.InputBox("Select the cell containing the servant formula", Type:=8)

On Error GoTo 0

If RefMaster.Count  1 Or RefServant.Count  1 Then
    MsgBox "The master and servant references may only be one cell each. Procedure cancelled"
    Exit Sub
End If

ServantFormula = RefServant.Formula

'get rid of the equal sign in servant formula if it exists
'add quotes to unquoted text string
'do nothing to plain numbers
If Left(ServantFormula, 1) = "=" Then
    ServantFormula = Right(ServantFormula, Len(ServantFormula) - 1)
ElseIf IsNumeric(ServantFormula) Then
    'do nothing
Else
    ServantFormula = Chr(34) & ServantFormula & Chr(34)
End If


NotFound = True
For l = 1 To 4

Select Case l
    Case 1
        x = 1: y = 1
    Case 2
        x = 0: y = 1
    Case 3
        x = 1: y = 0
    Case 4
        x = 0: y = 0
End Select

Do
    MasterFormula = RefMaster.Formula
    'Debug.Print RefServant.Address(x, y)
    i = InStr(MasterFormula, RefServant.Address(x, y))
    If i > 0 Then
        NotFound = False
        j = i + Len(RefServant.Address(x, y))
        k = Len(MasterFormula) - j + 1
        Work = Left(MasterFormula, i - 1) & ServantFormula
        Work = Work & Mid(MasterFormula, j, k)
        RefMaster.Formula = Work
    End If
Loop Until i = 0
Next l

If NotFound Then
    MsgBox ("The servant formula reference was not found in the master formula")
End If

Cancelled:

End Sub

Ken

Edited by kjktoo on 25-Feb-02 21:50.

Edited to change the word “sheets” to “ranges”

Jan Karel,

Once again you hit the nail on the head in your response. The annoyance here is why Microsoft uses a default collating sequence in VBA that is different from the one used when sorting ranges. Just one more thing to annoy the unwary like me I guess. I suppose it has to do with making VBA consistent with VB or something like that. Anyway…

Thanks for your help.

Ken