hope someone can help
i have this code bellow working fine because i determined the range and exactly gave A1 numeric value as loop counter and starting point.
Private Sub Worksheet_Change(ByVal Target As Range)
If (Range("A1") <> "") And (IsNumeric(Range("A1"))) And (Range("A1") > 0) Then
Dim X As Integer
If Not Intersect(Target, Range("A1")) Is Nothing Then
For X = 1 To Range("A1").Value
Sheet4.Range("b" & X).Value = Range("A1").Value
Next X
MsgBox "done"
Else
End If
Else
MsgBox "no numeric"
End If
End Sub
now
i want to expand this code above so when user fill sheet1 A1 by 5 then paste values to 5 cells in sheet2 starting from first empty cell in sheet2 eg: b1:b5 or b10:b15 respectifly.
in next time i dont know in which cell in sheet1 column A will be filled may be A2' A3'A10'A80 or any A column cells so when it filled next time do the same thing loop for entered value times and paste or assign values to sheet2 b first empty cell and next to loop count cells.
the solution is
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("H:H")
If (Target.Value <> "") And (IsNumeric(Target.Value)) And (Target.Value > 0) And ((Target.HasFormula) = False) Then
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Dim X As Integer
Sheets("sheet2").Activate
For X = Sheets("sheet2").Range("G100").End(xlUp).Row To Sheets("sheet2").Range("G100").End(xlUp).Row + Target.Value - 1
Sheets("sheet2").Range("B" & X + 1).Value = Sheets("sheet1").Range("B" & Target.Row)
Sheets("sheet2").Range("C" & X + 1).Value = Sheets("sheet1").Range("C" & Target.Row)
Sheets("sheet2").Range("D" & X + 1).Value = Sheets("sheet1").Range("D" & Target.Row)
Sheets("sheet2").Range("E" & X + 1).Value = Sheets("sheet1").Range("E" & Target.Row)
Sheets("sheet2").Range("G" & X + 1).Value = "Enter serial"
Next X
'MsgBox Target.Address
MsgBox "done" & X
Else
End If
Else
MsgBox "Wrong Value! You Must Enter Number greater Than 0 "
End If
End Sub
but now how can i update the rows in sheet2 if a user change the value on sheet1 Range("H:H")
i need a way to insert new rows if the user entered greater value than the first he entered.
or
i need a way to delete extra rows if the user entered smaller value than the first he entered.
Related
I'm trying to vlookup multiple selection(comma seperated) in single cell and get the ouput in next sheet in single cell with single value (Either "Y" or "N") based on the input criteria (opt LCD vendor column in input table image) and functional usecase column (slection of multiple value ";" seperated) in input table image:
Output conditions:
I should get the output as "Y" only if both/all/multiple selected criteria (functional usecaeses) are "Y"
if one selection is "N" and the remaining are "Y", output should be "N"
Not sure it could be done in VBA / formula. could you please help on it.
As of now, Used this code for multi select functionality in functional usecase column & another 2 column
Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To allow multiple selections in a Drop Down List in Excel (without repetition)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
'MsgBox "called" + ActiveSheet.Name + "::" + Target.Address
If ActiveSheet.Name = "Input" Then
If (Target.Column = 19 Or Target.Column = 6 Or Target.Column = 13) Then
'If Target.Address = "O" Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Sub test()
Set sh1 = Sheets("Sheet1")
Set rg = sh1.Range("B3", sh1.Range("B" & Rows.Count).End(xlUp))
Set sh2 = Sheets("Sheet2")
Set rgTbl = sh2.Range("A1", sh2.Range("F" & Rows.Count).End(xlUp))
For Each cell In rg
VL = "Y"
CL = rgTbl.Find(cell.Value, lookat:=xlWhole).Column
x = Split(cell.Offset(0, 1), ", ")
For i = LBound(x) To UBound(x)
VL = UCase(rgTbl.Find(x(i)).Offset(0, CL - 1))
If VL = "N" Then Exit For
Next
cell.Offset(0, 2).Value = VL
Next
End Sub
sh1 is the sheets where your "OPT LCD Vendor" reside.
So, change the sh1 according to your sheet name.
rg is the range of your "OPT LCD Vendor" header.
The code assumed that the data starts from cell B3 to the last rows which has value. rg values for example are : Outsystems, Any, Mendix, Unqork, etc.
sh2 is the sheet where your table has Y N.
So, change the sh2 according to your sheet name.
rgTbl is the range of the table in sh2.
The code assumed that the table starts from cell A1 to whatever last row in column F which has value. Change the range according to your need.
The process:
The code loop to each cell in rg,
get the value of the cell,
then find what column in rgTable this value exist, the CL variable.
The code split the value of the cell.offset(0,1) if the value has a comma separated.
For example, based on your image - the x variable will have two values : Life Origination and Accelerated Underwriting.
Then the code loop the value of x to get the VL is Y or N
Once it get the VL is N, it exit the loop, but it will continue if the value is not N. Finally the VL value (the result is Y or N) is put in column D of sh1 at the row of the looped cell, assuming that there is nothing in column D.
FYI, the value in column C of sh1 must always comma separated then one space. For example : Life Origination, Accelerated Underwriting ---> correct. Life Origination,Accelerated Underwriting ---> not correct.
This if I'm not mistaken to get what you mean.
My VBA is not running once a cell data is changed.
On my worksheet I have VBA running in Column F and G.
Column G has data validation that I want to trigger based on the numerical value input in column F.
Example:
Column F has a numerical value of 2.5 which results in Column G displaying "Good Standing".
If I change the Column F value to < 2, I want Column G cell to show blank
and vice versa if Column F value is originally < 2, and I increase it to > 2 Column G will display "Good Standing.
Private Sub Worksheet_Change(ByVal Target As Range)
StrtRow = 2
EndRow = Range("F" & Rows.Count).End(xlUp).Row
For i = StrtRow To EndRow
If Range("F" & i).Value >= 2 Then
Range("G" & i).Value = "Good Standing"
End If
Next
End Sub
You're missing an Else clause to clear the contents if < 2. Taking #SJR 's comment into account, try this (not tested)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngWatched As Range: Set rngWatched = Me.Range("F:F")
Dim cl As Range
If Not Intersect(rngWatched, Target) Is Nothing Then
Application.EnableEvents = False
For Each cl In Intersect(rngWatched, Target)
If cl.Value >= 2 Then
cl.Offset(0, 1).Value = "Good Standing"
Else
cl.Offset(0, 1).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
I've defined a couple of ranges but have problems to define a new range with a few conditions. I'm trying to set a new range from target cell downwards until the length of first TRUE cell is larger than 3 characters. The new desired range would be "Range("C" & Target.Row & ":" & Range("C65536").End(xlDown).Address(0, 0))" but only for the for the cells that have 3 or less characters. The problem with that code is that it stops at the first non-empty cell. The final cell in the range would be the last cell with max 3 characters (and not empty) before a cell value has more than 3 characters.
For instance the new range would be C35:C47 which would then be applied for the adjacent cells as B35:B47. Later on in my code I would then use this new range (B35:B47) in a "for loop" to define new values for these adjacent cells.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim rng As Range, cell As Range
Set rng = Range("B" & Target.Row & ":" & Range("B65536").End(xlUp).Address(0, 0))
Set r = Target
If Target.Column = 3 And Selection.Column = 3 Then
If Intersect(Range("C:C"), r) Is Nothing Then Exit Sub
If r.Value = "" Then Exit Sub
If r.Offset(0, 1).Value <> "" Then Exit Sub
If r.Offset(0, -1).Value <> "" Then Exit Sub
Application.EnableEvents = False
r.Offset(0, -1) = Application.WorksheetFunction.Max(Range("Sheet1!B7:B" & r.Row))
For Each cell In rng
If IsNumeric(cell.Value) Then
If cell.Value <> "" Then
cell.Value = cell.Value + 1
End If
Else
MsgBox "Cell " & cell.Address(0, 0) & " does not have a number"
Exit Sub
End If
Next
Application.EnableEvents = True
End If
End Sub
The new range would then be used in a similar way as the "for-loop" in the example with the difference that "rng" would be the new range --> "For Each cell in rng2"...
hi I have a code to delete entire row if cell in column G ="YES". It works fine, but when copy cells from one workbook to another it deletes the last row that is paste. Same as if I drag cell to auto fill.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
'If Cell that is edited is in column U and the value is completed then
If Target.Column = 7 And Target.Value = "YES" Then
'Define last row on completed worksheet to know where to place the row of data
LrowCompleted = Sheets("EQUIP. OFF RENT").Cells(Rows.Count, "A").End(xlUp).Row
'Copy and paste data
Range(Target.Row & ":" & Target.Row).Copy Sheets("EQUIP. OFF RENT").Range("A" & LrowCompleted + 1)
End If
If Target.Column = 7 And Target.Value = "YES" Then
Range(Target.Row & ":" & Target.Row).Delete
End If
Application.EnableEvents = True
After analyzing your code, it's a classical problem with the On Error Resume Next, combined with the Application.EnableEvents = False.
Even if there is an error in the code, the job is still running. That's why the last cell is deleted after a paste for example.
To avoid this, i simply erase the error resume next and the enableevents, and add this line before the first If statement :
If Target.Column = 1 Then Exit Sub
So please try this :
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then Exit Sub
If Target.Column = 7 And Target.Value = "YES" Then
'Define last row on completed worksheet to know where to place the row of data
LrowCompleted = Sheets("EQUIP. OFF RENT").Cells(Rows.Count, "A").End(xlUp).Row
'Copy and paste data
Range(Target.Row & ":" & Target.Row).Copy Sheets("EQUIP. OFF RENT").Range("A" & LrowCompleted + 1)
End If
If Target.Column = 7 And Target.Value = "YES" Then
Range(Target.Row & ":" & Target.Row).Delete
End If
End Sub
I have the following spreadsheet. When ever there is an x in cell B I need to populate the d and e cells in the same row using an equation I have.
if there is no x in the b cell I need to manually enter values into cells d & e.
How do I make my code non-row specific?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim val As String
val = Range("B3").Value
If val = "x" Then
Range("E3").Value = Range("d2").Value * Range("G2").Value
Range("D3").Value = Range("D2").Value
End If
End Sub
I'm not sure if I understand correctly, but if you have a parameter: row = 3 you can use Range("E" & row) instead of Range("E3").
Put a loop around that where you vary 'row' for the rows you want to modify.
Hope that helps!
You've created a sub procedure around the Worksheet_SelectionChange event. In fact, you require Worksheet_Change and you need to,
disable event handling so you can write new values/formulas to the worksheet without running the Worksheet_Change on top of itself.
loop through each matching cell in Target to compensate for circumstances when Target can be more than a single cell,
add error control.
Rewrite:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Dim t As Range
For Each t In Intersect(Target, Range("B:B"))
If LCase(t.Value) = "x" Then
'I've made these formulas relative to each target
'you may want to make some absolute references
t.Offset(0, 3) = t.Offset(-1, 2) * t.Offset(-1, 5)
t.Offset(0, 2) = t.Offset(-1, 2)
Else
t.Offset(0, 2).resize(1, 2) = vbnullstring
End If
Next t
End If
safe_exit:
Application.EnableEvents = True
End Sub
Please try below code.
It loop through all non empty rows in column B and check if there is value: x
If so it populate your formulas.
Sub new_sub()
' get last_row of data
last_row = ActiveSheet.UsedRange.Rows.Count
' loop through all rows with data and check if in column B any cell contains value: x
For i = 1 To last_row
' if there is any cell with value: x
' then add below formulas
If Cells(i, 2).Value = "x" Then
' for column E: take value from row above for col D and G and multiple
Range("E" & i).Value = Range("d" & i - 1).Value * Range("G" & i - 1).Value
' for column D: take value from row above
Range("D" & i).Value = Range("D" & i - 1).Value
End If
Next i
End Sub