I'm new to vba and frustrated.
I have the following code :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim VolRange As Range
Dim AffectVolRange As Range
Set VolRange = ActiveSheet.Range("AH:AK")
Set AffectVolRange = Intersect(Target, VolRange)
If Not AffectVolRange Is Nothing Then
Dim vRow As Variant
For Each vRow In AffectVolRange.Rows
With VolRange
Cells(vRow.Row, 37).Value = .Cells(vRow.Row, 34).Value * .Cells(vRow.Row, 35).Value *
.Cells(vRow.Row, 36).Value
End With
Next vRow
End If
End Sub
Initial value in columns 34,35,36, is null
You almos got it.
Take into account that your column indexes are relative to your new range, so 1, 2, 3, 4.
Also you need to disable the events with Application.EnableEvents = False to avoid recursive call to the function on the cells changed by the code event.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim VolRange As Range
Dim AffectVolRange As Range
Set VolRange = ActiveSheet.Range("AH:AK")
Set AffectVolRange = Intersect(Target, VolRange)
If Not AffectVolRange Is Nothing Then
Dim vRow As Variant
Application.EnableEvents = False
For Each vRow In AffectVolRange.Rows
With VolRange
.Cells(vRow.Row, 4).Value = .Cells(vRow.Row, 1).Value _
* .Cells(vRow.Row, 2).Value _
* .Cells(vRow.Row, 3).Value
End With
Next vRow
Application.EnableEvents = True
End If
End Sub
Related
Below code is working good with same workbook. But when I am trying to get VLOOKUP value from another workbook, it is not getting the value.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCell As Range, m1 As Variant ', m2 As Variant
On Error GoTo Hello:
If Application.Intersect(Target, Range("C2:C100001")) Is Nothing Then Exit Sub
For Each rngCell In Intersect(Target, Range("C2:C100001"))
If Len(rngCell.Value) > 0 Then
'This line is working good
'm1 = Application.VLookup(rngCell.Value, ThisWorkbook.Sheets("AllVehicleNumbers").Range("B2:C100001"), 2, False)
'But this is not working
m1 = Application.VLookup(rngCell.Value, Workbooks(ThisWorkbook.Path & "\VehicleNumbers.xlsx").Worksheets("AllVehicleNumbers").Range("B2:C100001"), 2, False)
If Not IsError(m1) Then
Application.EnableEvents = False
rngCell.Value = m1
Application.EnableEvents = True
End If
End If
Next
Hello:
End Sub
This will work on a closed workbook:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, rng As Range, v, frm
On Error GoTo haveError
Set rng = Application.Intersect(Target, Me.Range("C2:C100001"))
If rng Is Nothing Then Exit Sub
'Note your formula will vary a little if you're looking up numeric values
' (no quotes around the lookup value)
frm = "=VLOOKUP(""<v>"",'" & ThisWorkbook.Path & _
"\[VehicleNumbers.xlsx]AllVehicleNumbers'!B2:C100001,2,FALSE)"
For Each c In rng.Cells
v = Trim(c.Value)
If Len(v) > 0 Then
Application.EnableEvents = False
c.Formula = Replace(frm, "<v>", v)
c.Calculate
If IsError(c.Value) Then
c.Value = v 'no match - replace the original value
c.Font.Color = vbRed 'flag no match
Else
c.Value = c.Value 'convert to value
c.Font.Color = vbBlack 'clear any flag
End If
Application.EnableEvents = True
End If
Next
Exit Sub
haveError:
Application.EnableEvents = True
End Sub
This is just a sample I am testing the code in this data. I have three columns in sheet2. I have to delete the empty cells. This is the updated code which is working for column B only. You can check the snapshot
Sub delete()
Dim counter As Integer, i As Integer
counter = 0
For i = 1 To 10
If Cells(i, 1).Value <> "" Then
Cells(counter + 1, 2).Value = Cells(i, 1).Value
counter = counter + 1
End If
Next i
End Sub
Sample screenshot
If all you want is to delete the empty cells, give this a try...
Sub DeleteBlankCells()
Dim rng As Range
On Error Resume Next
Set rng = Intersect(ActiveSheet.UsedRange, Range("A:C"))
rng.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End Sub
Not the most elegant solution but it works.
Option Explicit
Sub delete()
Dim rCells As Range, rCell As Range, sFixCell As String
Set rCells = Range("A1:A13")
For Each rCell In rCells
If rCell = "" Then
sFixCell = rCell.Address
Do While rCell.Value = ""
rCell.delete Shift:=xlUp
Set rCell = Range(sFixCell)
Loop
End If
Next rCell
End Sub
I am creating an Excel spreadsheet. I have 2 separate functions that I need to combine but I am not sure how to smash them together. I know I can only have 1 change event. The first function will unprotect the sheet (column c is locked), auto populate column C when data is entered in to column A or erase C when A is erased and re-protect when complete. The second will return the cell focus to the next row, column A, when data is entered into A and B. Separately they work as needed.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Unprotect Password:="my password"
If Target.Column = 1 Then
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Target.Offset(0, 1 - Target.Column).Value = "" Then
Target.Offset(0, 3 - Target.Column).Clear
Exit Sub
End If
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 2).Value = Date & " " & Time
r.Offset(0, 2).NumberFormat = "m/d/yyyy h:mm am/pm"
Next r
Application.EnableEvents = True
End If
Protect Password:="my password"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
If Not Target.Cells.CountLarge > 1 Then
If Not Intersect(Target, Columns(1)) Is Nothing Then
Target.Offset(, 1).Select
ElseIf Not Intersect(Target, Columns(2)) Is Nothing Then
Target.Offset(1, -1).Select
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
How about this, seems to do what you want, as I understand the question.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngIntersect As Range
Dim rngCell As Range
On Error GoTo TidyUp
Application.EnableEvents = False
If Target.Column = 1 Then
Set rngIntersect = Intersect(Range("A:A"), Target)
For Each rngCell In rngIntersect
If rngCell.Value = "" Then
rngCell.Offset(0, 2).Value = ""
Else
rngCell.Offset(0, 2).Value = Date & " " & Time
rngCell.Offset(0, 2).NumberFormat = "m/d/yyyy h:mm am/pm"
End If
Next rngCell
End If
If Target.Column < 3 And Target.Value <> "" Then ' lose the 'And Target.Value <> ""' as desired
Cells(Target.Row + Target.Rows.Count, 1).Select
End If
TidyUp:
Set rngIntersect = Nothing
Set rngCell = Nothing
Application.EnableEvents = True
End Sub
I'd also suggest using UserInterfaceOnly in your worksheet.Protect, then you don't have to unprotect the sheet for VBA to act on the sheet.
Implement it in two Sub-Procedures on a modul, then just call both of them in the Event-Procedure.
I am using the spreadsheet to do inventory- scanning parts in bin
I am trying to add a A2 Value next to the (Target.Row, 5)(row 6)
how do I make A2 or A9 or the next scan Value show up on Column F so if column E & F don't match I know the part is sitting on the wrong bin
I have tried .Value = Target.Worksheet.Cells(Target.Row, 1).Value but not working
Here is my complete code
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Or Target.Column <> 1 Then Exit Sub
If Not SheetExists("WarehouseInventory") Then Exit Sub
Dim Result As Variant
Set Result = Sheets("WarehouseInventory").Cells.Range("E:E").Find(Target)
If Result Is Nothing Then
Target.Worksheet.Cells(Target.Row, 2) = "Data New Bin"
Else
Target.Worksheet.Cells(Target.Row, 2) = Result.Worksheet.Cells(Result.Row, 4)
Target.Worksheet.Cells(Target.Row, 3) = Result.Worksheet.Cells(Result.Row, 5)
Target.Worksheet.Cells(Target.Row, 4) = Result.Worksheet.Cells(Result.Row, 6)
Target.Worksheet.Cells(Target.Row, 5) = Result.Worksheet.Cells(Result.Row, 7)
End If
End Sub
Public Function SheetExists(SheetName As String) As Boolean
Dim ws As Worksheet
SheetExists = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = SheetName Then SheetExists = True
Next ws
End Function
this an example how you can achieve required result
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x&, y&
If Target.Column = 6 Then
y = 5: x = Target.Row
While Cells(x, y) <> "": x = x - 1: Wend
If Cells(Target.Row, 5) <> "" Then Cells(Target.Row, 6) = Cells(x, 1)
End If
End Sub
output
UPDATE
here your updated code, tested, works fine, insert it into "Cycle Count" sheet
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x&, y&, Result As Range, ws As Worksheet
Application.EnableEvents = 0
If Target.Count > 1 Then
Application.EnableEvents = 1
Exit Sub
End If
If Not Intersect(Target, [A1:A99999]) Is Nothing Then
With ThisWorkbook
For Each ws In .Worksheets
If ws.Name = "WarehouseInventory" Then
Set ws = .Worksheets("WarehouseInventory")
Set Result = ws.[E:E].Find(Target.Value)
Exit For
End If
Next ws
If Result Is Nothing Then
Target.Offset(, 1).Value = "Data New Bin"
Application.EnableEvents = 1
Exit Sub
Else
Target.Offset(, 1).Value = ws.Range(Result.Address).Offset(, -1).Value
Target.Offset(, 2).Value = ws.Range(Result.Address).Value
Target.Offset(, 3).Value = ws.Range(Result.Address).Offset(, 1).Value
Target.Offset(, 4).Value = ws.Range(Result.Address).Offset(, 2).Value
y = 5: x = Target.Row
While .ActiveSheet.Cells(x, y) <> "": x = x - 1: Wend
Target.Offset(, 5).Value = .ActiveSheet.Cells(x, 1).Value
End If
End With
End If
Application.EnableEvents = 1
End Sub
sample file here http://www.filedropper.com/book1_5
What about Target.Worksheet.Cells(Target.Row, 6).Value = Target.Worksheet.Cells(Target.Row,1).Value ?
If you want only A2, in all rows substitute Target.Row with 2
My codes gives me a Object Required 424 error on this line:
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
My full code:
Private Sub Worksheet_Change(ByVal Target As Range)
' If Target.Count > 1 Then Exit Sub
' If Target.Column > 2 Then Exit Sub
Application.EnableEvents = False
If Target.Column = 6 Then
If Target.Offset(0, 1).Value <> "" Then
MsgBox "You must only fill in one of the two columns"
Target.ClearContents
GoTo ExitSub
End If
End If
If Target.Column = 7 Then
If Target.Offset(0, -1).Value <> "" Then
MsgBox "You must only fill in one of the two columns"
Target.ClearContents
GoTo ExitSub
End If
End If
Dim arrData() As Variant
Dim i As Long
Dim lngRow As Long
Dim myNum As Variant
Dim ws As Worksheet
myNum = Target.Value
If Target.Column = 6 Then
With BogieInspectionPoints 'this is a sheet name
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData = .Range("a1:b" & lngRow)
End With
End If
If Target.Column = 7 Then
With WagonInspectionPoints 'this is a sheet name
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData = .Range("a1:b" & lngRow)
End With
End If
For i = 1 To lngRow
If myNum = arrData(i, 1) Then
Cells(Target.Row, 8).Value = arrData(i, 2)
Exit For
End If
Next
ExitSub:
Application.EnableEvents = True
End Sub
It looks like those sheet variables aren't set.
You will need to add this at the top.
Dim BogieInspectionPoints as Worksheet
Dim WagonInspectionPoints as Worksheet
Set BogieInspectionPoints = ActiveWorkbook.Sheets("BogieInspectionPoints")
Set WagonInspectionPoints = ActiveWorkbook.Sheets("WagonInspectionPoints")
I was assuming there was other code. When you add this line all the With statements should process correctly using the code you posted.
What you're doing with the With statements is shorthanding the object. Instead of writing
BogieInspectionPoints.Range("A1")
'More code
You can write
With BogieInspectionPoints
.Range("A1")
End With
It keeps you from having to write the full object name out.