In my script After a Validation Item is Selected the code then selects the next cell and opens the validation list, what I am trying to accomplish is after that selection to then select the cell in the next column and then open that validation list to make a selection. I cannot seem to allow the one script to run after the other. The top snippet is where I am trying to implement the second If Not to run after the first If Not. The bottom snippet is the entire script.
If TheSize = "" Then
MsgBox "Now pick the size for your " & vbNewLine & TheItem, , "Apparel Selection" & " (Item# " & TheId & ")"
Target.Offset(, 2).Select
Target.Offset(, 2).Application.SendKeys "%{UP}"
End If
If TheColor = "" Then
MsgBox "Now pick the Color for your " & vbNewLine & TheItem, , "Apparel Selection" & " (Item# " & TheId & ")"
Target.Offset(, 3).Select
Target.Offset(, 3).Application.SendKeys "%{UP}"
End If
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A3")) Is Nothing Then
Range("B3:B3").ClearContents
Range("C3:C6").ClearContents
Range("D3:D6").ClearContents
Range("E3:E6").ClearContents
Range("F3:F6").ClearContents
End If
If Target.Count = 1 Then
If Cells(Target.Row, Target.Column + 1).Value = "" Then
TheItem = Target.Value
TheSize = Target.Offset(, 2).Value
TheColor = Target.Offset(, 3).Value
TheId = Target.Offset(, 4).Value
If Not Intersect(Target, Range("C3:C6")) Is Nothing Then
ItemVal = InputBox("How many of the " & (TheItem) & "'s Do you want?", "Apparel Selection" & " (Item# " & TheId & ")")
Cells(Target.Row, Target.Column + 1).Value = ItemVal
If TheSize = "" Then
MsgBox "Now pick the size for your " & vbNewLine & TheItem, , "Apparel Selection" & " (Item# " & TheId & ")"
Target.Offset(, 2).Select
Target.Offset(, 2).Application.SendKeys "%{UP}"
End If
If TheColor = "" Then
MsgBox "Now pick the Color for your " & vbNewLine & TheItem, , "Apparel Selection" & " (Item# " & TheId & ")"
Target.Offset(, 3).Select
Target.Offset(, 3).Application.SendKeys "%{UP}"
End If
If ItemVal = "" Then
MsgBox "Pick The Item You Really Really Want", , "Canceled!"
Application.EnableEvents = False
Target.ClearContents
End If
End If
End If
End If
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C3:C6" & Cells(Rows.Count, "D").End(xlUp).Row)) Is Nothing Then
If Target.Value = vbNullString Then
Range("D" & Target.Row) = vbNullString
Range("E" & Target.Row) = vbNullString
Range("F" & Target.Row) = vbNullString
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
End Sub
Related
I am trying to implement a functionality that obliged the user filling in column B a value from a dropdown list to also fill right after another cell column I from same row and sheet. With possibility to cancel the action, removing then his choice at column B. I am thinking to do that thanks to a message box to fill, clicking ok would then fill the cell at column I.
I found nothing about this kind of function on the internet. Could you help me finding a simple code?
Thank you
I did this that answers perfectly my need, for information
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 2 Then
ThisRow = Target.Row
If Target.Value = "Sourcing" Then
inputdate = InputBox("Please enter Sourcing end date target dd/mm/yyyy", "Enter Sourcing end date", Format(inputdate, "mm/dd/yyyy"))
If inputdate = "" Or inputdate = vbNullString Then
Range("I" & ThisRow).Value = ""
Range("B" & ThisRow).Value = ""
Else
If IsDate(inputdate) Then
inputdate = Format(CDate(inputdate), "mm/dd/yyyy")
Range("I" & ThisRow).Value = inputdate
Else
MsgBox "Wrong date format"
Range("I" & ThisRow).Value = ""
Range("B" & ThisRow).Value = ""
End If
End If
ElseIf Target.Value = "Phasing out" Then
inputdate = InputBox("Please enter History target date dd/mm/yyyy", "Enter History date", Format(inputdate, "mm/dd/yyyy"))
If inputdate = "" Or inputdate = vbNullString Then
Range("I" & ThisRow).Value = ""
Range("B" & ThisRow).Value = ""
Else
If IsDate(inputdate) Then
inputdate = Format(CDate(inputdate), "mm/dd/yyyy")
Range("I" & ThisRow).Value = inputdate
Else
MsgBox "Wrong date format"
Range("I" & ThisRow).Value = ""
Range("B" & ThisRow).Value = ""
End If
End If
ElseIf Target.Value = "History" Then
Range("I" & ThisRow).Value = Date
ElseIf Target.Value = "" Then
Range("I" & ThisRow).Value = ""
End If
End If
End Sub
Had to find a trick about date format that was changing from dd/mm to mm/dd, add some condition if window is cancelled or date empty and this works fine
I have the code below which, in a simple request form, gives requestor an option to add a line for the same user.
When "Yes" is selected from a drop-down menu, a new line populates with the same Name and Alias used in the previous row, while other rows below it would move down by one row accordingly.
The code to ADD a new line (works fine) is as follows:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
With ThisWorkbook.Worksheets("AWS Applications")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "Yes" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Insert
.Range("A" & Target.Row & ":C" & Target.Row).Copy .Range("A" & Target.Row + 1 & ":C" & Target.Row + 1)
Application.EnableEvents = True
End If
End With
End Sub
I modified the above code as follows so it does remove a row below if the "No" option is selected. And it is working properly:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
With ThisWorkbook.Worksheets("AWS Applications")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "Yes" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Insert
.Range("A" & Target.Row & ":C" & Target.Row).Copy .Range("A" & Target.Row + 1 & ":C" & Target.Row + 1)
Application.EnableEvents = True
End If
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "No" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Delete
Application.EnableEvents = True
End If
End With
End Sub
However, I want to make sure that a below row is deleted after selecting "No" only in cases where the below row that is to be deleted contains same data as the row above. As it is now, it removes the below line in any case, i.e. even if the requestor previously didn't click "Yes", and that's not a desired outcome.
I've been trying to modify the "No" condition as follows but still struggling:
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "No" Then
If Range("A" & Target.Row & ":C" & Target.Row).Value = Range("A" & Target.Row + 1 & ":C" & Target.Row + 1).Value Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Delete
Application.EnableEvents = True
End If
End If
Could you please help?
FOLLOW-UP:
The code I'm having now is this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
With ThisWorkbook.Worksheets("AWS Applications")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "Yes" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Insert
.Range("A" & Target.Row & ":C" & Target.Row).Copy .Range("A" &
Target.Row + 1 & ":C" & Target.Row + 1)
Application.EnableEvents = True
End If
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "No" Then
AllOk = True
For Each xCel In UpperRow.Cells
If AllOk And (xCel.Value <> xCel.Offset(1, 0).Value) Then
AllOk = False
End If
Next xCel
If AllOk Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Delete
Application.EnableEvents = True
End If
End If
End With
End Sub
I keep getting '424' error "Object required" and the debug highlights this: For Each xCel In UpperRow.Cells
Could you please help? Apologies I'm a beginner in this...
As an indicative answer
AllOk = True
for each xCel in UpperRow.Cells
if AllOk and (xCel.Value <> xCel.Offset(1,0).Value) then
AllOk = False
End If
Next xCel
IF AllOk then
' Delete the Row
End If
You'll need to fill in some details and maybe some error checking - not a full answer
I dynamically update the cells in columns A and B, and join both values on each row (using &) and place the values in column C.
My purpose is fulfilled by detecting duplicate names when firstName (Column A values) and LastName (column B values) are entered twice. An empty value (observed when the msgbox is displayed) pops up when I delete the duplicate name followed by the first occurrence.
This is an issue at times, especially because sometimes the msgbox does not go away. ie the code crashes.
How can I prevent the empty value, or msgBox from being displayed? I suspect something is wrong with my if statement.
VBA code I placed in the worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
If WorksheetFunction.CountIf(Range("c1:c12"), Target.Offset(0, 1).Value) > 1 And _
Target.Offset(0, 1).Value <> " " Then
MsgBox Target.Offset(0, 1).Value & " is a Duplicate Entry" & vbNewLine & _
" ENTER A NEW NAME", vbInformation, "Duplicate Detected"
Target.Offset(0, 0).Value = " "
Target.Offset(0, 0).Select
ElseIf WorksheetFunction.CountIf(Range("c1:c12"), Target.Offset(0, 2).Value) > 1 And _
Target.Offset(0, 1).Value <> " " Then
MsgBox Target.Offset(0, 2).Value & " is a Duplicate Entry" & vbNewLine & _
" ENTER A NEW NAME", vbInformation, "Duplicate Detected"
Target.Offset(0, 0).Value = " "
Target.Offset(0, 0).Select
Else: Exit Sub
End If
End Sub
If i wanted to create a sheet with
-2 -1 0
ColA ColB ColC
First1 Last1 First1Last1
First2 Last2 First2Last2
First3 Last3 First3Last3
First4 Last4
I would personally start with conditional formatting for ColC to flag what is a duplicate, in case there is an issue, which circumvents a messagebox.
If i did need a messagebox, i would set up similar to what you have:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns(3)) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Application.CountIfs(Range("C1:C12"),Target.Value) > 1 Then 'checks for first/last name
MsgBox("The name " & Target.Offset(0,-2).Value & " " & Target.Offset(0,-1).Value & " already exists." & vbNewLine & "Please enter a new name.")
End If
End Sub
Edit1:
Given the data entry for colA and colB, would this be more appropriate? I utilized the row of the target, so the negative offset shouldn't be of concern, since you know that colA is first name and colB is last name.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Dim r as long
r = target.row
If isempty(cells(r,1)) or isempty(cells(r,2)) then exitsub
If Application.CountIfs(Range("B1:B12"),cells(r,2).Value,Range("A1:A12"),cells(r,1).Value) > 1 Then 'checks for first/last name
MsgBox("The name " & cells(r,1).Value & " " & cells(r,2).Value & " already exists." & vbNewLine & "Please enter a new name.")
End If
End Sub
Edit2:
In verifying the use of no values and some values, this macro has been working for my testing (i added the clear contents and .select so you are back on the line you should be adding data); i also added a range specification related to the intersect in case you are adding values like first/last to a random place outside of a1:b12:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range(Cells(1, 1), Cells(12, 2))) Is Nothing Then Exit Sub
Dim r As Long
r = Target.Row
If IsEmpty(Cells(r, 1)) Or IsEmpty(Cells(r, 2)) Then Exit Sub
If Application.CountIfs(Range("B1:B12"), Cells(r, 2).Value, Range("A1:A12"), Cells(r, 1).Value) > 1 Then 'checks for first/last name
MsgBox ("The name " & Cells(r, 1).Value & " " & Cells(r, 2).Value & " already exists." & vbNewLine & "Please enter a new name.")
Cells(r, 1).ClearContents
Cells(r, 2).ClearContents
Cells(r, 1).Select
End If
End Sub
I want to change some text when saving to worksheet, the cell has multiple textbox values together.
When textbox is colored red in VBA-excel, it has to save that text value in the cell in red font.
When it is not red, it has to save in black font color.
Range("w" & lmaxrows + 1).Value = "S " & TextBox42.Value & " |VP " & TextBox43.Value & " |NP " & TextBox47.Value & " |E " & TextBox48.Value
If TextBox42.BackColor = vbRed Then
With Range("w" & lmaxrows)
d = "S " & TextBox42.Value
If Range("w" & lmaxrows).Value > "" Then Replace(Range("w"), d, Range("w")).Font.Color = vbRed Range("w")).Font.Color = vbRed
end if
end if
I have this for now, but it doesn't work.
How about checking the length of your textbox and then using that to change the color of that many characters on the Cell:
Private Sub CommandButton1_Click()
Sheet1.Cells(1, 1).Value = TextBox1.Text & " some other text"
lengthofRed = Len(TextBox1.Text)
'check the length of the text box
If TextBox1.BackColor = vbRed Then
Sheet1.Cells(1, 1).Characters(1, lengthofRed).Font.Color = vbRed
End If
End Sub
EDIT:
Changing the above to match your code, I believe the following should do what you expect:
Range("w" & lmaxrows + 1).Value = "S " & TextBox42.Value & " |VP " & TextBox43.Value & " |NP " & TextBox47.Value & " |E " & TextBox48.Value
If TextBox42.BackColor = vbRed Then
With Range("w" & lmaxrows)
d = "S " & TextBox42.Value
If Range("w" & lmaxrows).Value > "" Then
Range("W" & lmaxrows + 1).Characters(1, Len(d)).Font.Color = vbRed
End If
End If
I am working on a VBA application, where when I select an option from a drop down list (created using data validation) a few columns should populate automatically. It is working fine if I select an option from the drop down list for each cell individually. However if I drag down an option over a few rows, only the data for the top row gets populated whereas that for the remaining rows do not. How do I tackle this? This is my code under Worksheet_Change function
Private Sub Worksheet_Change(ByVal Target As range)
If Target.Column = 22 Then
ThisRow = Target.Row
On Error GoTo ExitSub
If Target.Value = "E" Then
range("W" & ThisRow).Value = range("R" & ThisRow).Value
range("X" & ThisRow).Value = ""
On Error GoTo 0
ElseIf Target.Value = "T" Then
range("W" & ThisRow).Value = ""
range("X" & ThisRow).Value = range("S" & ThisRow).Value
ElseIf Target.Value = "M" Then
range("W" & ThisRow).Value = ""
range("X" & ThisRow).Value = ""
ElseIf Target.Value = "N" Then
range("W" & ThisRow).Value = 0
range("X" & ThisRow).Value = 0
ElseIf Target.Value = "R" Then
range("W" & ThisRow).Value = range("T" & ThisRow).Value
range("X" & ThisRow).Value = range("U" & ThisRow).Value
End If
End If
Exit Sub
ExitSub:
Exit Sub
End Sub
If you're selecting multiple cells, then you have more than one row and/or column in your Target range, so statements referencing .Column and .Row are going to be ambiguous.
If you wrap this code in a loop that steps through each cell within the range, it should update the whole range, not just the first cell.