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
Related
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
I am fairly new to writing code in excel VBA. Most of this code is some I have tried to replicated based on what other people have wrote. The problem I am having is I have a quantity counter and when a barcode is scanned into the cell (A4) it will add the barcode to a new cell (Starts at C8 and goes down) and if this barcode is already scanned once and is scanned again it will add one to the quantity. Now I am trying to add a date and time next to it as a barcode is scanned. This works but has an issue I can't figure out. The barcode must be scanned twice for the date to appear in the proper cell. This is an issue because it raises the quantity up one more than it should. Please help.
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Address
Case "$A$4"
If Target.Value <> "" Then
On Error Resume Next
Set xitem = Range("C8", Range("C" & Rows.Count) _
.End(xlUp)).Find(Range("A4").Value)
With xitem.Offset(0, -1)
.Value = .Value + 1
.Offset(0, 1).Select
End With
With xitem.Offset(0, 1)
.Value = Date & " " & Time
.NumberFormat = "m/d/yyyy h:mm AM/PM"
End With
On Error GoTo 0
If xitem Is Nothing Then
With Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
.Value = Target.Value
.Offset(0, -1) = 1
End With
End If
Range("A4") = ""
Range("A4").Select
End If
Adds quantity
Case "$C$4"
If Target.Value <> "" Then
On Error Resume Next
Set xitem = Range("C8", Range("C" & Rows.Count).End(xlUp)) _
.Find(Range("C4").Value)
With xitem.Offset(0, -1)
.Value = .Value - 1
End With
If xitem Is Nothing Then MsgBox Target & " cannot be found " _
& "and cannot be removed."
Range("C4") = ""
Range("C4").Select
On Error GoTo 0
End If
Removes quantity (I am going to add an out time to this just trying to get the initial scan time in first)
Case "$E$4" 'find
If Target.Value <> "" Then
On Error Resume Next
Set xitem = Range("C8", Range("C" & Rows.Count).End(xlUp)) _
.Find(Range("E4").Value)
If xitem Is Nothing Then
MsgBox Target & " was not found."
Range("E4").Select
End If
Range("E4") = ""
xitem.Select
On Error GoTo 0
End If
End Select
End Sub
This is what I am using to take me directly to a barcode that has already been scanned.
Sorry if this post is badly formatted never posted before. Any and all help with this issue is appreciated. A photo of the spread sheet is also attached.
You are repeating some things within your code which you only need to do once, like the Find() for example.
Here's one alternative approach:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Adding As Boolean, Finding As Boolean, Subtracting As Boolean
Dim f As Range, v
Select Case Target.Address(True, True)
Case "$A$4": Adding = True
Case "$C$4": Subtracting = True
Case "$E$4": Finding = True
Case Else: Exit Sub
End Select
v = Trim(Target.Value)
If Len(v) = 0 Then Exit Sub
Set f = Me.Range("C8").Resize(1000, 1).Find(v, lookat:=xlWhole)
If Adding Then
If f Is Nothing Then
'not found: add as new row
Set f = Me.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
f.Value = v
End If
f.Offset(0, 1).Value = f.Offset(0, 1).Value + 1
doDate f.Offset(0, -1)
Target.Value = ""
ElseIf Subtracting Then
If f Is Nothing Then
MsgBox v & " not found for subtraction!"
Else
f.Offset(0, 1).Value = f.Offset(0, 1).Value - 1
doDate f.Offset(0, -1)
Target.Value = ""
End If
Else 'finding
If Not f Is Nothing Then
f.EntireRow.Select
Target.Value = ""
Else
MsgBox v & " not found."
End If
End If
If Adding Or Subtracting Then Target.Select
End Sub
Sub doDate(c As Range)
With c
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End Sub
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
I am trying to write a VBA macro to track changes of a worksheet in a separate sheet(showing the history of changes) by displaying a comment box on the cell with some color, automatically when the user search and updates the data in the userform.
Below code is for search and update:
''this code is for updating the data in the userform''
Private Sub cmdupdate_Click()
If Me.TextBox1.Value = "" Then
MsgBox "SL No Can Not be Blank!!!", vbExclamation, "SL No"
Exit Sub
End If
SLNo = Me.TextBox1.Value
Sheets("Sheet1").Select
Dim rowselect As Double
rowselect = Me.TextBox1.Value
rowselect = rowselect + 1
Rows(rowselect).Select
Cells(rowselect, 2) = Me.TextBox2.Value
Cells(rowselect, 3) = Me.TextBox3.Value
Cells(rowselect, 4) = Me.TextBox4.Value
Cells(rowselect, 5) = Me.TextBox5.Value
Cells(rowselect, 6) = Me.TextBox6.Value
End Sub
''The below code is used to search from the excel sheet and displays in the userform''
Private Sub cmdSearch_Click()
Do
DoEvents
row_number = row_number + 1
item_in_review = Sheets("Sheet1").Range("A" & row_number)
If item_in_review = TextBox1.Text Then
TextBox2.Text = Sheets("Sheet1").Range("B" & row_number)
TextBox3.Text = Sheets("Sheet1").Range("C" & row_number)
TextBox4.Text = Sheets("Sheet1").Range("D" & row_number)
TextBox5.Text = Sheets("Sheet1").Range("F" & row_number)
TextBox6.Text = Sheets("Sheet1").Range("E" & row_number)
End If
Loop Until item_in_review = ""
End Sub
Now I try to add the below code for track changes after updating the excel sheet with userform but I am getting an error in this line "Target.Comment.Text Text:=OldVal" not able to get the solution to complete my task.
Sub Worksheet_Change(ByVal Target As Range)
Dim X As Integer
Set Wb = ThisWorkbook
ShtName = "Edits Log"
If Target.Cells.Count > 1 Then Exit Sub
X = EndRow + 1
Wb.Sheets(ShtName).Range("A" & X).Value = ActiveSheet.Name
Wb.Sheets(ShtName).Range("B" & X).Value = Target.Address
Wb.Sheets(ShtName).Range("C" & X).Value = OldVal
Wb.Sheets(ShtName).Range("D" & X).Value = Target.Value
Wb.Sheets(ShtName).Range("E" & X).Value = Now()
Wb.Sheets(ShtName).Range("F" & X).Value = Environ("username")
Target.Interior.ColorIndex = 6
On Error Resume Next
Target.AddComment
On Error GoTo 0
Target.Comment.Visible = False
Target.Comment.Text Text:=OldVal
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
OldVal = Target.Value
End Sub
From the comments, the error is thrown because oldVal is Empty. When a previously blank cell is changed, the Selection Change fires, and since there was no previous value in the cell, oldVal will be Empty.
The Worksheet Change code needs to handle that possibility, as well as the possibility that Target contains an error - e.g. #VALUE! or #N/A.
Stripping out the portion that writes to the "Edits Log" tab, your Worksheet Change might look something like the code below:
Option Explicit
Public oldVal 'should be a Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
oldVal = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Target.Interior.ColorIndex = 6
On Error Resume Next
Target.AddComment
On Error GoTo 0
With Target.Comment
.Visible = False
If Not IsEmpty(oldVal) And Not IsError(oldVal) Then
.Text CStr(oldVal)
Else
.Text "Previously blank or an error"
End If
End With
End Sub
To preface the situation, I am new to VBA programming so any help would be greatly appreciated.
I have two columns; one where the user can input a dollar value ("AL") and another where the user can input a percent value ("AK"). The object is to enable the user to input either value (% or $) and have the other value calculate. For instance, if the user inputs 10% in "AL", the applicable $ value will generate in "AK" and vice versa.
Below is the code I've come up with thus far but it isn't working. Any thoughts/suggestions would be greatly appreciated! Thank you!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Set cell = Range("AK9:AL50")
'Application.EnableEvents = False Application.EnableEvents = True'
If Not Application.Intersect(cell, Range(Target.Address)) Is Nothing Then
If Target.Column = 37 Then ' Value in first column changed
Range("AL" & Target.Row).Value = Range("AK" & Target.Row).Value / Range("V" & Target.Row).Value
Exit Sub
ElseIf Target.Column = 38 Then ' value in second column changed
Range("AK" & Target.Row).Value = Range("AL" & Target.Row).Value * Range("V" & Target.Row).Value
Exit Sub
'Application.EnableEvents = False Application.EnableEvents = True'
End If
End If
End Sub
You need to remove the Exit Subs
And the Application.EnableEvents = True needs to be outside the if.
The first time you ran it with the Application.EnableEvents = False line enabled it turned off the events and since you exited the sub before turning them back on it stayed off and the sub was never called again.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Set cell = Range("AK9:AL50")
Application.EnableEvents = False
If Not Application.Intersect(cell, Range(Target.Address)) Is Nothing Then
If Target.Column = 37 Then ' Value in first column changed
Range("AL" & Target.Row).Value = Range("AK" & Target.Row).Value / Range("V" & Target.Row).Value
ElseIf Target.Column = 38 Then ' value in second column changed
Range("AK" & Target.Row).Value = Range("AL" & Target.Row).Value * Range("V" & Target.Row).Value
End If
Application.EnableEvents = True
End If
End Sub
My guess is right now your events are disabled.
Run this code after putting the correct code above in your sheet:
Sub foooo()
Application.EnableEvents = True
End Sub
This will turn the events back on. It is only needed once.
You can have a better use of your Worksheet_Change parameters, like Target.
1.Instead of:
Range("AL" & Target.Row).Value
you can use:
Target.Offset(, 1).Value
2.Instead of:
Range("AK" & Target.Row).Value
you can use:
Target.Value
3.Also Range(Target.Address) actually is Target
Code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Set cell = Range("AK9:AL50")
Application.EnableEvents = False
If Not Application.Intersect(cell, Target) Is Nothing Then
If Target.Column = 37 Then ' Value in first column changed
Target.Offset(, 1).Value = Target.Value / Range("V" & Target.Row).Value
ElseIf Target.Column = 38 Then ' value in second column changed
Target.Offset(, 2).Value = Target.Value * Range("V" & Target.Row).Value
End If
End If
Application.EnableEvents = True '<-- RESTORE SETTING OUTSIDE THE IF
End Sub