Executing macro on cell change.

[Brad]

Hi,

I have the following code which I would like to execute each after a change
is made to any cell in column A. Only trouble is if I place it in a
"Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" sub, it
gets locked in an endless loop. Does anyone have any suggestions?

___

Sub Code()
Application.ScreenUpdating = False
Cells(1, 1).Select
Do While Not IsEmpty(ActiveCell)
CellNum = ActiveCell.Value
CellLength = Len(CellNum)
CellVal = Empty
If IsNumeric(CellNum) Then
CellNum = CellNum * 100
Else
Application.ScreenUpdating = True
Err = MsgBox(" Non numeric value in cell?", vbOKCancel)
If Err = vbCancel Then End
End If
Application.ScreenUpdating = False
For i = 1 To CellLength
If Mid(CellNum, i, 1) = 1 Then CellVal = CellVal & "A"
If Mid(CellNum, i, 1) = 2 Then CellVal = CellVal & "B"
If Mid(CellNum, i, 1) = 3 Then CellVal = CellVal & "C"
If Mid(CellNum, i, 1) = 4 Then CellVal = CellVal & "D"
If Mid(CellNum, i, 1) = 5 Then CellVal = CellVal & "E"
If Mid(CellNum, i, 1) = 6 Then CellVal = CellVal & "F"
If Mid(CellNum, i, 1) = 7 Then CellVal = CellVal & "G"
If Mid(CellNum, i, 1) = 8 Then CellVal = CellVal & "H"
If Mid(CellNum, i, 1) = 9 Then CellVal = CellVal & "I"
If Mid(CellNum, i, 1) = 0 Then CellVal = CellVal & "Z"
Next

ActiveCell.Offset(0, 1).Value = CellVal
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
End Sub

 

[Bob Phillips]

Try this

Sub Code()
On Error GoTo ws_exit
Application.EnableEvents = True
Application.ScreenUpdating = False
Cells(1, 1).Select
Do While Not IsEmpty(ActiveCell)
CellNum = ActiveCell.Value
CellLength = Len(CellNum)
CellVal = Empty
If IsNumeric(CellNum) Then
CellNum = CellNum * 100
Else
Application.ScreenUpdating = True
Err = MsgBox(" Non numeric value in cell?", vbOKCancel)
If Err = vbCancel Then End
End If
Application.ScreenUpdating = False
For i = 1 To CellLength
If Mid(CellNum, i, 1) = 1 Then CellVal = CellVal & "A"
If Mid(CellNum, i, 1) = 2 Then CellVal = CellVal & "B"
If Mid(CellNum, i, 1) = 3 Then CellVal = CellVal & "C"
If Mid(CellNum, i, 1) = 4 Then CellVal = CellVal & "D"
If Mid(CellNum, i, 1) = 5 Then CellVal = CellVal & "E"
If Mid(CellNum, i, 1) = 6 Then CellVal = CellVal & "F"
If Mid(CellNum, i, 1) = 7 Then CellVal = CellVal & "G"
If Mid(CellNum, i, 1) = 8 Then CellVal = CellVal & "H"
If Mid(CellNum, i, 1) = 9 Then CellVal = CellVal & "I"
If Mid(CellNum, i, 1) = 0 Then CellVal = CellVal & "Z"
Next

ActiveCell.Offset(0, 1).Value = CellVal
ActiveCell.Offset(1, 0).Select
Loop
ws_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[JE McGimpsey]

If I understand you correctly:

Private Sub Workbook_SheetChange( _
ByVal Sh As Object, ByVal Target As Excel.Range)
Dim vSubs As Variant
Dim sTemp As String
Dim i As Long
With Target
If .Count > 1 Then Exit Sub
If .Column = 1 Then
If IsNumeric(.Value) Then
sTemp = CStr(Int(.Value * 100))
vSubs = Array( _
"Z", "A", "B", "C", "D", "E", "F", "G", "H", "I")
For i = 1 To Len(sTemp)
Mid(sTemp, i, 1) = vSubs(CLng(Mid(sTemp, i, 1)))
Next i
On Error Resume Next
Application.EnableEvents = False
.Value = sTemp
Application.EnableEvents = True
On Error GoTo 0
Else
MsgBox "Non numeric value in cell"
End If
End If
End With
End Sub

 

[Brad]

Hi,

Thanks, this is great. Though I don't get how it works?

2 minor issues are - I would like to keep the original number entered in A
column, and have the 'code' for it placed in the B column. The other is how
do I specify which column is the column to read from and which is the column
to write too. EG: I might put my numbers in the H column and want the code
written to the I column?

Thanks again.
Brad.

 

[Bob Phillips]

This writes to the next column.

The target column is picked out with this cod

If .Column = 1 Then

change the number to whicehever column that you want


Private Sub Workbook_SheetChange( _
ByVal Sh As Object, ByVal Target As Excel.Range)
Dim vSubs As Variant
Dim sTemp As String
Dim i As Long
With Target
If .Count > 1 Then Exit Sub
If .Column = 1 Then
If IsNumeric(.Value) Then
sTemp = CStr(Int(.Value * 100))
vSubs = Array( _
"Z", "A", "B", "C", "D", "E", "F", "G", "H", "I")
For i = 1 To Len(sTemp)
Mid(sTemp, i, 1) = vSubs(CLng(Mid(sTemp, i, 1)))
Next i
On Error Resume Next
Application.EnableEvents = False
.offset(0,1).Value = sTemp
Application.EnableEvents = True
On Error GoTo 0
Else
MsgBox "Non numeric value in cell"
End If
End If
End With
End Sub


--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Brad]

Thanks Again Bob!

I really appreciate your help. And I think I learnt something, which is
always good. One last question, how would you make the code recognise
autofilling of cells. (eg: Selecting A1:A10 - typing 12.95 - CTRL / Enter)
and filling down of cells. (eg: Typing 12.95 into A1, grabing it's bottom
righthand corner and dragging it to A10)?

Thanks
Brad.

 

[Bob Phillips]

Here is the code Brad.

I have coded it so that if you try to do it on multiple columns, it exits
out. I have also added a constant defining the target column to ease
maintenance

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Excel.Range)
Const WS_COL As Long = 1
Dim vSubs As Variant
Dim sTemp As String
Dim i As Long
Dim cell As Range
With Target
If .Columns.Count > 1 Then Exit Sub
If .Column = WS_COL Then
For Each cell In Target
If IsNumeric(cell.Value) Then
sTemp = CStr(Int(cell.Value * 100))
vSubs = Array( _
"Z", "A", "B", "C", "D", "E", "F", "G", "H",
"I")
For i = 1 To Len(sTemp)
Mid(sTemp, i, 1) = vSubs(CLng(Mid(sTemp, i, 1)))
Next i
On Error Resume Next
Application.EnableEvents = False
cell.Offset(0, 1).Value = sTemp
Application.EnableEvents = True
On Error GoTo 0
Else
MsgBox "Non numeric value in cell"
End If
Next cell
End If
End With
End Sub


--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)