I created VBA code to apply a formula which should do the following: when the user selects a range of cells, the formula is applied 3 columns on the right side of the data of the selection. For example if the user selects range G8:G18, when the user executes the macro, the formula should be applied on range J8:J18 from the data of range G8:G18
However the formula is in range G8 instead of being applied on range J8:J18.
Sub ghjkk()
Dim c As Range
Dim rng As Range
Set rng = Selection.Offset(0, 3)
For Each c In rng
ActiveCell.FormulaR1C1 = _
"=IF(RC[-3]=0.2,""Y5"",IF(RC[-3]=0.1,""Y6"",IF(RC[-3]=0,""V0"",IF(RC[-3]=0.021,""Y3"",IF(RC[-3]=0.055,""Y4"",FALSE)))))"
Next c
End Sub
Try
Sub ghjkk()
Dim c As Range
Dim rng As Range
Set rng = Selection.Offset(0, 3)
For Each c In rng
c.FormulaR1C1 = _
"=IF(RC[-3]=0.2,""Y5"",IF(RC[-3]=0.1,""Y6"",IF(RC[-3]=0,""V0"",IF(RC[-3]=0.021,""Y3"",IF(RC[-3]=0.055,""Y4"",FALSE)))))"
Next c
End Sub
If needed, change sheet name and range & import the below code on Worksheet_Change Event on the specific sheet.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("G8:G18")) Is Nothing Then
Application.EnableEvents = False
If Cells(Target.Row, 4).Value = "0.2" Then
Cells(Target.Row, 10).Value = "Y5"
ElseIf Cells(Target.Row, 4).Value = "0.1" Then
Cells(Target.Row, 10).Value = "Y6"
ElseIf Cells(Target.Row, 4).Value = "0" Then
Cells(Target.Row, 10).Value = "V0"
ElseIf Cells(Target.Row, 4).Value = "0.021" Then
Cells(Target.Row, 10).Value = "Y3"
ElseIf Cells(Target.Row, 4).Value = "0.055" Then
Cells(Target.Row, 10).Value = "Y4"
Else: Cells(Target.Row, 10).Value = "False"
End If
Application.EnableEvents = True
End If
End Sub
Related
I am trying to solve an issue with a piece of code. I am aware this question has been asked before but i cannot get those solutions to work. The below worksheet change event does not trigger when i copy and paste data into column A but does when the user clicks into the cells manually how can i get round this?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Application.EnableEvents = False
For Each cell In Target
If Not Application.Intersect(cell, Range("A7:A1048576")) Is Nothing Then
If Not IsNumeric(cell.Value) Then
cell.Value = vbNullString
MsgBox ("Please re-enter, value entered contains non-numeric entry")
End If
End If
Next cell
If Not Intersect(Target, Range("A7:A1048576")) Is Nothing Then
On Error Resume Next
If Target.Value = "" Or Target.Value = "0" Then
Target.Offset(0, 12) = ""
Target.Offset(0, 13) = ""
Else
Target.Offset(0, 12).Value = Format(Now, "mm/dd/yyyy HH:mm:ss")
Target.Offset(0, 13).Value = Environ("username")
End If
End If
Application.EnableEvents = True
End Sub
This code should just about do what you want. Please try it.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
If Not Application.Intersect(Target, Range("A7:A1048576")) Is Nothing Then
Set Target = Target.Columns(1) ' remove all cells outside column A
Application.EnableEvents = False
For Each Cell In Target.Cells
With Cell
If .Value = "" Or .Value = 0 Then
.Offset(0, 12).Resize(1, 2).Value = vbNullString
Else
If Not IsNumeric(.Value) Then
.Value = vbNullString
MsgBox ("Please re-enter, value entered contains non-numeric entry")
.Select
Exit For
Else
.Offset(0, 12).Value = Format(Now, "mm/dd/yyyy HH:mm:ss")
.Offset(0, 13).Value = Environ("username")
End If
End If
End With
Next Cell
Application.EnableEvents = True
End If
End Sub
In columns Bk and CB they both contain formula's that will result in a code. Now CB will also contain four codes and a remove statement which if they match with the cell in column BK in the same row then take the value from CB and paste over hence overriding the value in BK with that code and then paste it red.
the above should be done only on a filtered range though.
The ignore #N/A are in there as the overide column will error out on almost everyline except for when there is a code to overide.
This macro works perfectly without the visible cells statement at the end of my with range line but as soon as the visible cells statement is added the loop only goes up to #N/A and disregards the rest of the ElseIF statement.
Here is my code below:
Option Explicit
Sub Override()
Dim x As Workbook: Set x = ThisWorkbook
Dim rRange As Variant, fltrdRng As Range, aCell As Range, rngToCopy As Range
Dim ws As Worksheet
Dim LR As Long
Dim LR2 As Long
Dim SrchRng As Range, cel As Range
Dim mRow
mRow = 2
Set ws = x.Worksheets("Data")
LR = ws.Range("CB" & ws.Rows.Count).End(xlUp).Row
LR2 = ws.Range("BK" & ws.Rows.Count).End(xlUp).Row
'clears any filters on the sheet
ws.AutoFilterMode = False
' turns formula's to manual
Application.Calculation = xlManual
'copies down the formula in Column BK ignoring the last two rows as they have already been pasted over.
ws.Range("BK2:BK4 ").AutoFill Destination:=ws.Range("BK2:BK" & LR2 - 2)
'filters on N/A's and 10 as these are the codes we are interested in overiding
ws.Range("$A$1:$CB$1").AutoFilter Field:=19, Criteria1:=Array( _
"10", "N/A"), Operator:= _
xlFilterValues
' will loop through all cells in specified range and ignore any error's and #N/A's and will paste over the code overided in CB column to the BK column if conditions are met.
On Error Resume Next
While IsEmpty(ws.Range("CB" & mRow)) = False
With ws.Range("CB" & mRow).SpecialCells(xlCellTypeVisible)
If .Value = "#N/A" Then
ElseIf .Value = "1234" Then
.Offset(0, -17).Value = "1234"
.Offset(0, -17).Interior.Color = vbRed
ElseIf .Value = "1235" Then
.Offset(0, -17).Value = "1235"
.Offset(0, -17).Interior.Color = vbRed
ElseIf .Value = "1236" Then
.Offset(0, -17).Value = "1236"
.Offset(0, -17).Interior.Color = vbRed
ElseIf .Value = "Remove" Then
.Offset(0, -17).Value = "Remove"
.Offset(0, -17).Interior.Color = vbRed
ElseIf .Value = "1237" Then
.Offset(0, -17).Value = "1237"
.Offset(0, -17).Interior.Color = vbRed
End If
End With
mRow = mRow + 1
Wend
'turn Formula 's back to automatic
Application.Calculation = xlAutomatic
End Sub
With ws.Range("CB" & mRow).SpecialCells(xlCellTypeVisible)
Using SpecialCells on just one cell is problematic.
Instead, use it on the entire filtered column, like this, which will replace your entire While...Wend loop (by the way, While...Wend is obsolete):
On Error Resume Next
Dim visibleCells As Range
Set visibleCells = ws.Range("CB2:CB" & LR).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If visibleCells Is Nothing Then Exit Sub
Dim cell As Range
For Each cell In visibleCells
If Not IsError(cell.Value) Then
Select Case cell.Value
Case "1234", "1235", "1236", "1237", "Remove"
cell.Offset(0, -17).Value = cell.Value
cell.Offset(0, -17).Interior.Color = vbRed
End Select
End If
Next
I am very new to VBA but pretty good at formulas. I am working on a time stamp issue. I have the code written so that if I choose from a validation list in E3 it will give me a time stamp in F3. I want this to be true of all cells in the E column starting with E3. I will have between 500 and 15000 records (rows). The code I am using is pasted below. Thanks in advance for any suggestions.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 And Target.Row = 3 Then
If Target.Value = "" Then
Cells(3, 6).Value = ""
Else
Cells(3, 6).Value = Format(Now, "mm/dd/yyyy HH:mm:ss")
End If
End If
End Sub
How's this?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 And Target.Row >= 3 Then
i = Target.Row
If Target.Value = "" Then
Cells(i, 6).Value = ""
Else
Cells(i, 6).Value = Format(Now, "mm/dd/yyyy HH:mm:ss")
End If
End If
End Sub
The fastest way to do this is to select the entire range a set the value once using an array. This is done with the .Value property of a Range when it contains multiple cells.
Private Sub SetDate(ByVal Target As Range, Optional bybal RowCount as Long = 0)
Dim i as Long
' Check if row count needs to be found
If RowCount = 0 Then
'Count non-empty rows from target down
RowCount = Target.Worksheet.Range(Target, Target.End(xlDown).Rows.Count
End If
' Target entire range of cells that are going to be affected
Set Target = Target.Resize(RowCount, 6)
Dim vals() as Variant
' Read values from worksheet
vals = Target.Values
' Make changes in memory here
For i=1 to RowCount
if IsEmpty(vals(i,1)) Then
vals(i, 6) = vbNullString
Else
vals(i, 6) = Format(Now, "mm/dd/yyyy HH:mm:ss")
End If
Next i
' Write values into worksheet
Target.Value = vals
End Sub
Scenario:
I have two worksheets the same except for "some content" in Sheet2 column C-E, and Sheet1 containing a Worksheet_SelectionChange handler
When I click on column B in Sheet1 the Worksheet_SelectionChange changes the cell colour and then sets column C-E to that of Sheet2 Column C
Problem:
Trouble is it falls over on an application error...
Can anyone help please, this is really annoying...just how do i copy the data from Sheet2 to Sheet 1 in a Worksheet_SelectionChange handler?
If I set S1C = "X" (as in hardcoded it's fine), its when I try to reference the cell from the second sheet that it doesn't work.
many thanks in advance,
Best regards
Code as follows:
Public benRel
Public rskOpt
Public resOpt
Public getRow
Public getCol
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitSubCorrectly
'turn off multiple recurring changes
Application.EnableEvents = False
'do not allow range selection
If Target.Cells.Count > 1 Then GoTo ExitSubCorrectly
'only allow selection within our range
Set myRange = Range("B8:B24")
If Not Application.Intersect(Target, myRange) Is Nothing Then
' At least one cell of Target is within the range myRange.
' Carry out some action.
getRow = Target.Row
getCol = Target.Column
Select Case Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Style
Case "Normal"
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Style = "Accent1"
getData
putData
Case "Accent1"
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Style = "Normal"
Range(Cells(Target.Row, Target.Column + 1), Cells(Target.Row, Target.Column + 3)).Value = ""
Case Else
End Select
Else
' No cell of Target in in the range. Get Out.
GoTo ExitSubCorrectly
End If
ExitSubCorrectly:
' go back and turn on changes
' MsgBox Err.Description
Worksheets("Sheet1").Select
Application.EnableEvents = True
End Sub
Sub getData()
Worksheets("Sheet2").Select
Range(Cells(getRow, getCol), Cells(getRow, getCol)).Select
benRel = Range(Cells(getRow, getCol), Cells(getRow, getCol)).Offset(0, 1).Value
rskOpt = Range(Cells(getRow, getCol), Cells(getRow, getCol)).Offset(0, 2).Value
resOpt = Range(Cells(getRow, getCol), Cells(getRow, getCol)).Offset(0, 3).Value
End Sub
Sub putData()
Worksheets("Sheet1").Select
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Offset(0, 1).Value = benRel
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Offset(0, 2).Value = rskOpt
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Offset(0, 3).Value = resOpt
End Sub
it looks to me like you could replace all three routines with
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitSubCorrectly
'turn off multiple recurring changes
Application.EnableEvents = False
'do not allow range selection
If Target.Cells.Count > 1 Then GoTo ExitSubCorrectly
'only allow selection within our range
Set myRange = Range("B8:B24")
If Not Application.Intersect(Target, myRange) Is Nothing Then
' At least one cell of Target is within the range myRange.
' Carry out some action.
With Cells(Target.Row, Target.Column)
Select Case .Style
Case "Normal"
.Style = "Accent1"
.Offset(0, 1).Resize(, 3).Value = Worksheets("Sheet2").Cells(getRow, getCol).Offset(0, 1).Resize(, 3).Value
Case "Accent1"
.Style = "Normal"
.Offset(0, 1).Resize(, 3).ClearContents
Case Else
End Select
End With
End If
ExitSubCorrectly:
' go back and turn on changes
' MsgBox Err.Description
Application.EnableEvents = True
End Sub
Private Sub CommandButton1_Click()
Dim rng As Range
Dim cell As Variant
Set rng = Range("C8:C12")
For Each cell In rng
Sheets("Sheet1").Range("A1:H7").Copy Destination:=Sheets("Quantity").Range("XFD4").End(xlToLeft).Offset(-3, 3)
Sheets("Quantity").Range("XFD1").End(xlToLeft).Offset(0, 1).Value = cell.Offset(1, -1).End(xlUp).Value
Sheets("Quantity").Range("XFD2").End(xlToLeft).Offset(0, 1).Value = cell.Value
Sheets("Quantity").Range("XFD3").End(xlToLeft).Offset(0, 1).Value = cell.Offset(0, 1).Value
Next
End Sub
What I want to accomplish here is to skip blank cell/row. Because it will copy empty data to the sheet. Is there any method e.g. Not isEmpty or isBlank for this For loop? Thanks in advance.
You should be able to check IsEmpty(cell) to see if a cell is empty.
For example (untested):
For Each cell In rng
If Not IsEmpty(cell) Then
Sheets("Sheet1").Range("A1:H7").Copy Destination:=Sheets("Quantity").Range("XFD4").End(xlToLeft).Offset(-3, 3)
Sheets("Quantity").Range("XFD1").End(xlToLeft).Offset(0, 1).Value = cell.Offset(1, -1).End(xlUp).Value
Sheets("Quantity").Range("XFD2").End(xlToLeft).Offset(0, 1).Value = cell.Value
Sheets("Quantity").Range("XFD3").End(xlToLeft).Offset(0, 1).Value = cell.Offset(0, 1).Value
End If
Next