Allow alpha numeric values instead of isnumeric - excel

I have the below code for entering a function and copying the orientation and borders of the above line.
But in this it only accept numeric values, how can i modify the code so that i can enter alpa numeric values in that cell.
Below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
If IsNumeric(Target.Value) Then ' Check if cell contains a numeric value
If Target.Value <> "" Then
Range("A" & Target.Row).Formula = "=IF(B" & Target.Row & "<>"""",ROW()-ROW($A$15)+1,"""")"
' Copy border, border color and orientation from row above
With Range("A" & Target.Row & ":H" & Target.Row)
.Borders.LineStyle = .Offset(-1, 0).Borders.LineStyle
.Borders.Color = .Offset(-1, 0).Borders.Color
.Orientation = .Offset(-1, 0).Orientation
End With
Else
' Check if entire row in column B is empty
If WorksheetFunction.CountA(Range("B" & Target.Row & ":H" & Target.Row)) = 0 Then
' Delete entire row
Rows(Target.Row).Delete
Else
' Clear contents of column A to H for the row where value was deleted in column B
Range("A" & Target.Row & ":H" & Target.Row).ClearContents
End If
End If
End If
End If
End Sub

Here's a small Function you could add to your code, to give it IsAlphaNumeric functionality.
Function IsAlphaNumeric(t) as Boolean
Dim i as Long
IsAlphaNumeric = True
For i = 1 To Len(t)
If Not (Mid(t, i, 1) Like "[A-z0-9]") Then
IsAlphaNumeric = False
Exit For
End If
Next
End Function
You can use it like this:
If IsAlphaNumeric(Target.Value) Then ' Check if cell contains alpha-numeric value

Related

Ignore blanks or values of 0 in column X

Currently if there is a blank/0 in a cell in column X, that trigger a return of YYY. I need this code to ignore cases when it finds a blank cell or value 0 in column X
Sub Macro()
Columns("G:G").NumberFormat = "General"
Dim lr As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
With Range("K8:K" & lr)
.Formula = Replace("=IF(SUMPRODUCT(--(TEXT(A$8:A$#,""mmyy"")=TEXT(A8,""mmyy"")),--(S$8:S$#=S8),--(X$8:X$#=X8))" _
& "=SUMPRODUCT(--(TEXT(A$8:A$#,""mmyy"")=TEXT(A8,""mmyy"")),--(S$8:S$#=S8)),"""",""YYY"")", "#", lr)
.Value = .Value
End With
End Sub
This is just pseudo-code (not tested, obviously), but I believe you're looking for something like:
for each c in Range("K8:K" & lr).Cells
if (c.Value <> "") and (c.Value <> 0) then
c.Formula = ...
end if
next

VBA Trigger Worksheet Change with Copy/Paste

I am trying to use VBA to populate spreadsheet column G with an image file based on the value of column B on the same row of the sheet. If I manually enter the value into column B everything works great, however I have a long list and was hoping to copy/paste multiple values into column B. When I paste it seems like the worksheet change is not triggered and column H is not populated with images. The code I am using is below, any help would be greatly appreciated. Thanks!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
On Error GoTo son
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture And shp.TopLeftCell.Address = Target.Offset(0, 4).Address Then shp.Delete
Next
If Target.Value <> "" And Dir(ThisWorkbook.Path & "\" & Target.Value & ".jpg") = "" Then
'picture not there!
MsgBox Target.Value & " Doesn't exist!"
End If
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 5).Top
Selection.Left = Target.Offset(0, 5).Left
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = Target.Offset(0, 5).Height
.Width = Target.Offset(0, 5).Width
End With
Target.Offset(1, 0).Select
son:
End Sub
When you paste multiple value the Target parameter becomes array of range you paste.
And it is also a array of 1 member if you paste only 1 row.
So, use For..Next loop to complete all row you were paste. And change all Target to Target(i) and change some code as below.
For i = 1 To Target.Rows.Count
If Target(i).Value <> "" And Dir(ThisWorkbook.Path & "\" & Target(i).Value & ".jpg") = "" Then
'picture not there!
MsgBox Target(i).Value & " Doesn't exist!"
Else
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target(i).Value & ".jpg").Select
Selection.Top = Target(i).Offset(0, 5).Top
Selection.Left = Target(i).Offset(0, 5).Left
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = Target(i).Offset(0, 5).Height
.Width = Target(i).Offset(0, 5).Width
End With
End If
Next

vba code for putting described sign automatically to all columns of a clicked row

if i double click in column g of any row that is defined i need the symbol to be shown in each column such as h,i,j,k,l,m of the row double clicked in column g
my vba code is
If Not Intersect(Target, Range("h3:m20")) Is Nothing Then
If Target.Value = "Ð" Then
Target.Value = "Ï"
Exit Sub
End If
If Target.Value = "x" Then Target.Value = "Ð"
If Target.Value = "Ï" Then Target.Value = "x"
If Target.Value = Empty Then Target.Value = "Ð"
End If
If Not Intersect(Target, Range("G3:G20")) Is Nothing Then
If Target.Value = "Ð" Then
Range("G" & Target.Row & "M" & Target.Row).Value = "Ï"
Exit Sub
End If
If Target.Value = "x" Then Range("G" & Target.Row & "M" & Target.Row).Value = "Ð"
If Target.Value = "Ï" Then Range("G" & Target.Row & "M" & Target.Row).Value = "x"
If Target.Value = Empty Then Range("G" & Target.Row & "M" & Target.Row).Value = "Ð"
End If
End Sub
this is not working...please help....thank you
Your Range references are missing a colon. You also mentioned in your explaination:
"if i double click in column g of any row that is defined i need the symbol to be shown in each column"
Right now you checking against an Intersect with the wrong Range. So try the below instead:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Only activate when its a cell in range `G3:G20`
If Intersect(Target, Range("G3:G20")) Is Nothing Then Exit Sub
'Do something here with your values and IF statements
Target.Offset(0, 1).Resize(1, 6).Value = "TEST" 'Purely to test
End Sub
Not a finished code, but you'll be able to add the missing pieces to the puzzle at the bottom.

Excel VBA onChange Event

I'm trying to fire an onChange event when value entered to column A.
Now I want this, if I enter any value from Column A to Column AS, the event will fire and if I remove any value from same columns it will work as Code is written.
Also if I copy and paste a multiple data it's not working, also if I'm removing the multiple data it's not working.
Can anyone help on this? Below is the code.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim currentRow As Integer
If Not Intersect(Target, Columns("A")) Is Nothing Then
If Target.Value <> "" Then
currentRow = Target.Row
Target.Parent.Range("A" & currentRow & ":AS" & currentRow).Interior.ColorIndex = 15
Target.Parent.Range("A" & currentRow & ":AS" & currentRow).Borders.LineStyle = xlContinuous
End If
If Target.Value = "" Then
currentRow = Target.Row
Target.Parent.Range("A" & currentRow & ":AS" & currentRow).Interior.ColorIndex = 0
Target.Parent.Range("A" & currentRow & ":AS" & currentRow).Borders.LineStyle = xlNone
End If
End If
End Sub
Target.Value only has a value if a single cell is selected. If you select more than one cell it becomes an array and your If statement will always evaluate to False.
Here is one way to change your code. I was in a bit of a hurry so it could probably be done much better but should get you started.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Not Intersect(Target, Columns("A")) Is Nothing Then
If Application.WorksheetFunction.CountA(Target) = 0 Then
' Empty Range
For Each rw In Target.Rows
Target.Parent.Range("A" & rw.Row & ":AS" & rw.Row).Interior.ColorIndex = 0
Target.Parent.Range("A" & rw.Row & ":AS" & rw.Row).Borders.LineStyle = xlNone
Next rw
Else
' Not Empty
For Each rw In Target.Rows
Target.Parent.Range("A" & rw.Row & ":AS" & rw.Row).Interior.ColorIndex = 15
Target.Parent.Range("A" & rw.Row & ":AS" & rw.Row).Borders.LineStyle = xlContinuous
Next rw
End If
End If
End Sub

Excel VBA Clear Contents from two rows if a third one is deleted

Need some help with a little code.
I have created the following code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
ThisRow = Target.Row
If Target.Column = 5 Then
Range("C" & ThisRow).Value = Format(DateTime.Now, "hh:mm")
Range("D" & ThisRow).Value = Format(DateTime.Now, "mm/dd/yyyy")
Range("C:D").EntireColumn.AutoFit
End If
End Sub
Basically, if I entered information on any cell on column E, code will display "Time" in the same row on column C and "Date" on the same row on column D.
This is working fine. However, I would like to have this code deleting the information on columns C and D if the entry on columns E gets deleted and the cell is empty.
Thanks for any help in advance.
Try the code below:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim ThisRow As Long
ThisRow = Target.Row
If Target.Column = 5 Then
' if current Cell in Column E is empty, clear contents
If Range("E" & ThisRow).Value = "" Then
Range("C" & ThisRow).ClearContents
Range("D" & ThisRow).ClearContents
Else
Range("C" & ThisRow).Value = Format(DateTime.Now, "hh:mm")
Range("D" & ThisRow).Value = Format(DateTime.Now, "mm/dd/yyyy")
End If
Range("C:D").EntireColumn.AutoFit
End If
End Sub

Resources