i have the below macro which removes values in column H when column I has a "Yes" in. is there a way to change this into an automatic VBA that runs in the background?
Sub Remove_Column_H_Values()'
' Remove_Column_H_Values Macro
'
'
Application.Goto Reference:="R7C9"
ActiveSheet.ListObjects("Table11").Range.AutoFilter Field:=8, Criteria1:= _
"<>"
Application.Goto Reference:="R7C8"
Range("H8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Application.Goto Reference:="R7C9"
ActiveSheet.ListObjects("Table11").Range.AutoFilter Field:=8
Range("I8").Select
End Sub
You can add a button to your Sheet with this code.
Sub Remove_Column_H_Values()
Dim i As Integer
For i = 1 To 100 'depends on how long your Values go
If Yoursheet.Cells(i, 9) = "Yes" Then
Yoursheet.Cells(i, 8) = ""
End If
Next
End Sub
Automatic, after Typing Yes in column I:
(In the sheet-module)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column = 9 And UCase(Target.Value) = "YES" Then Target.Offset(, -1) = Empty
End Sub
Related
I need help with Excel VBA code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
If the third column we enter -1 it will clear the row. If we enter 1000 it will be copied to another sheet and deleted from the current sheet.
The above code is working fine. Instead of clearing row data, I want to delete that row.
So added
Line 4 With Target.EntireRow.ClearContents to With Target.EntireRow.Delete
But it shows an error.
It would help to know what error you get. Assuming the error is caused because the Week Schedule sheet does not exist, you can add a check for that. After that, your code works fine:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
SheetExistsOrCreate ("Week Schedule")
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
Function SheetExistsOrCreate(name As Variant)
For i = 1 To Worksheets.Count
If Worksheets(i).name = "MySheet" Then
exists = True
End If
Next i
If Not exists Then
Worksheets.Add.name = name
End If
End Function
Please, try the next adapted code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
Application.EnableEvents = False
If LCase(Target.Value) = -1 Then
Target.EntireRow.Delete
ElseIf Target.Value = 1000 Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
Application.EnableEvents = True
End If
End Sub
The above code assumes that the Target value means a number, not a string looking as a number. If a string, you can place them between double quotes, as in your initial code.
Of course, a sheet named "Week Schedule" must exist in the active workbook and must not be protected.
I would like to create a script, I got two (2) workbooks and they are kind of related, on the first one I would like to activate a sheet find and offset one cell and select all the info. and in case the cell contains a "yes" in the new one would paste "Yes" instead of all the info. in the previous workbook.
Sub test2()
Dim SingleCell As Range
Dim Listcells As Range
Application.ScreenUpdating = False
Workbooks("OLD CAD").Sheets("Contract History-Modifications").Activate
ActiveSheet.Range("B:B").Find(" CM Name/Number", MatchCase:=True).Select
Range(ActiveCell.Address).Offset(2, 0).Select
Range(ActiveCell.Address, Range(ActiveCell.Address).End(xlDown)).Select
Selection.Offset(0, 13).Select
'ActiveSheet.Range(Selection.Address)
'MsgBox (Selection.Address)
Set Listcells = Range(Selection.Address)
For Each SingleCell In Listcells
'Select Case True
' Case Is = InStr(1, (SingleCell.Value), "Yes") > 0
If InStr(1, (SingleCell.Value), "Yes") > 0 Then
Workbooks("NEW CAD").Sheets("Contract History-Modifications").Activate
ActiveSheet.Range("i:j").Find("A. Did the CM change the price of the transaction?", MatchCase:=True).Activate
Range(ActiveCell.Address).Offset(1, 0).Select
Range(ActiveCell.Address).Value = "Yes"
ActiveCell.Offset(1, 0).Select
End If
'End Select
Next SingleCell
End Sub
I am trying to create a scoreboard using VBA in Excel. When users click on the button to enter (See image below), they will key in their names, id and numeric answer in a user form (So 3 text boxes for them to fill up).
After the user clicks submit in the userform, the value should be saved in Sheet 1 for collation (take note of the 4,000 in Cell D2, more on it later):
This is the code for the userform:
Private Sub CommandButton1_Click()
If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Then
If MsgBox("Your details are not complete! Do you want to continue?", vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If
End If
Worksheets("Sheet1").Select
'Worksheets("Sheet1").Range("A2").Select
ActiveCell = TextBox1.Value
ActiveCell.Offset(0, 1) = TextBox2.Value
ActiveCell.Offset(0, 2) = TextBox3.Value
ActiveCell.Offset(1, 0).Select
Call resetform
End Sub
Sub resetform()
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
UserForm1.TextBox1.SetFocus
End Sub
Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Not IsNumeric(TextBox3.Value) Then
MsgBox "Only numbers are allowed"
Cancel = True
End If
End Sub
By right, when users click on the submit answer command button, the values will be saved accordingly in Sheet1 with the code above.
However, my issue arises here now. I want to sort the values by absolute differences. I.e I want to compare all the numeric answers in Col C of Sheet1, to the target answer in Cell C3 of Sheet2.:
After calculating the absolute differences, I want to sort the rows according to the absolute differences in Ascending order. This is the code for the sorting:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim test As Variant
Dim calc As Variant
If Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
For i = 1 To Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
calc = Sheet1.Cells(i + 1, "C").Value
test = Sheet2.Cells(3, 3).Value
Sheet1.Cells(i + 1, "D").Value = Abs(test - calc)
Application.EnableEvents = False
Range("A:D").Sort Key1:=Range("D2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Application.EnableEvents = True
Next i
End If
End Sub
However, when I clear my fields in Sheet1, the 4,000 in Cell D2 appears. (I'm guessing it has to do with the 4,000 in the target answer minusing 0 since the fields are blank.) If I have new entries, and the difference is very huge, the sheet becomes messed up and looks like this:
When I key in another number with a huge absolute difference, the 4,000 is repeated and the previous largest absolute difference is replaced with the new largest absolute difference value. Does anyone know why?
For #Mikku this is the latest error!:
I think this will solve your problem. Looks like you are selecting any other cell before running the Userform, which in turn is the reason for those 2 blank rows. Try the Below and tell me if it's still happening.
Change:
Worksheets("Sheet1").Select
'Worksheets("Sheet1").Range("A2").Select
ActiveCell = TextBox1.Value
ActiveCell.Offset(0, 1) = TextBox2.Value
ActiveCell.Offset(0, 2) = TextBox3.Value
ActiveCell.Offset(1, 0).Select
With:
Dim last As Long
With Worksheets("Sheet1")
last = .Cells(.Rows.Count, "A").End(xlUp).row
.Range("A" & last + 1).Value = TextBox1.Value
.Range("B" & last + 1).Value = TextBox2.Value
.Range("C" & last + 1).Value = TextBox3.Value
End With
Change the Worksheet Event Code to this: (Untested)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim test As Variant
Dim calc As Variant
If Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
test = Worksheets("Sheet2").Cells(3, 3).Value
With Worksheets("Sheet1")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
calc = .Cells(i, "C").Value
.Cells(i, "D").Value = Abs(test - calc)
Next i
.Range("A:D").Sort Key1:=.Range("D2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Application.EnableEvents = True
End With
End If
End Sub
Demo:
Updated Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim test As Variant
Dim calc As Variant
If Not Intersect(Target, Range("E:E")) Is Nothing Then
Application.EnableEvents = False
Dim lst As Long
test = Worksheets("Target Answer").Cells(3, 3).Value
With Worksheets("Consolidation")
lst = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 3 To lst
calc = .Cells(i, "E").Value
.Cells(i, "F").Value = Abs(test - calc)
Next i
.Range("C2:F" & lst).Sort Key1:=.Range("F3"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Application.EnableEvents = True
End With
End If
End Sub
I'm trying to move to first cell of next row of column "A" in excel whenever enter key is pressed in Column "H". My code so far is below;
Private Sub move_to_next_row(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
ActiveCell.Offset(1, -7).Activate
End If
End Sub
There is no KeyDown event or something similar for worksheets. You can only check if a cell in column H was changed and then move to the first column in the next row.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Columns("H")) Is Nothing Then
Me.Cells(Target.Row + 1, "A").Select
End If
End Sub
Not For Points
Another way in case you want to trap the "Enter" key in Col H (irrespective of whether user made a change or not in column H)
Credits:
#Tom for Application.OnKey
#AsUsual for Worksheet_SelectionChange
Place this in the worksheet code area
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim wsName As String
wsName = ActiveSheet.Name
If ActiveCell.Column = 8 Then Application.OnKey "{Enter}", _
"'MoveCursor" & Chr(34) & wsName & Chr(34) & "'"
End Sub
Place this in the module.
Option Explicit
Sub MoveCursor(wsN As String)
If ActiveWorkbook.Name <> ThisWorkbook.Name Then GoTo CleanExit
If ActiveSheet.Name <> wsN Then GoTo CleanExit
Cells(ActiveCell.Row + 1, 1).Select
CleanExit:
'<~~ Reset the key to avoid undesirable sideeffects!
Application.OnKey "{Enter}"
End Sub
Try this (also gets triggered by the down arrow)
Option Explicit
Private col As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If .Column = 8 And col = 8 Then
Cells(.Row, 1).Select
col = 0
Exit Sub
End If
col = .Column
End With
End Sub
In your ThisWorkbook Object place the following
Private Sub Workbook_Open()
Application.OnKey "~", "move_to_next_row"
End Sub
And then run using F5
Then in a normal module place
Sub move_to_next_row()
Dim SelectRng As Range
On Error Resume Next
If ActiveCell.Column = 8 Then
Set SelectRng = ActiveCell.Offset(1, -7)
Else
If Application.MoveAfterReturn Then
Select Case Application.MoveAfterReturnDirection
Case xlToLeft
Set SelectRng = ActiveCell.Offset(0, -1)
Case xlToRight
Set SelectRng = ActiveCell.Offset(0, 1)
Case xlUp
Set SelectRng = ActiveCell.Offset(-1, 0)
Case xlDown
Set SelectRng = ActiveCell.Offset(1, 0)
End Select
End If
End If
On Error GoTo 0
If Not SelectRng Is Nothing Then
SelectRng.Activate
End If
End Sub
Whenever you press the enter key move_to_next_row will be called. If the ActiveCell is in column H it will move the ActiveCell to Column A
I am using this code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = True
On Error GoTo Errormask
With Target
If .Column = 30 And .Row > 16 And .Value = "Remove" Then
.EntireRow.Delete
Target.Offset(, 2).Select
End If
End With
Errormask:
Application.DisplayAlerts = False
Exit Sub
End Sub
If a user clicks on the cell in column 30 which contains "remove", it should delete the row and then select the cell 1 across.
This is not working. Please can someone show me where i am going wrong?
In your with, do the offset on the line below before deleting the entire row.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If Target.CurrentRegion.Count = 1 And Target.Cells.Count = 1 Then
If .Column = 30 And .Row > 16 And .Value Like "Remove" Then
.Offset(1, 2).Select
.EntireRow.Delete
End If
End If
End With
Application.DisplayAlerts = False
End Sub
Are you sure you have this in the code of your sheet and not in a module?
EDIT
I have added a new If to check the select cell isn't merged first, and only a single cell is selected.
Try the code below:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = True
On Error GoTo Errormask '<-- don't see the need for this line
With Target
If .Column = 30 And .Row > 16 And .Value Like "Remove" Then
.EntireRow.Delete
.Offset(, 2).Select
End If
End With
Errormask: '<-- don't see the need for this line
Application.DisplayAlerts = False
Exit Sub '<-- don't see the need for this line, anyway at the end of the Sub
End Sub