多个工作表更改公式 - 在下拉列表中选择某些条件时的多个操作

Question

我正在尝试为在下拉列表中选择某些条件时创建多个操作。我在下拉列表中有 6 个条目，其中 3 个需要自动操作。

第一个动作是..

When "4. Under Offer" is selected, an inputbox should popup requesting a "date" value to be inputted ("Please insert a date the property went under offer").该值可能是日期，但有时只是文本。然后需要将该值输入到单元格右侧的单元格中，并带有“4. Under Offer”下拉值。

第二个动作是……

When "5. Exchanged" is selected, an inputbox should popup requesting a "date" value to be inputted ("Please insert a date the property Exchanged").该值可能是日期，但有时只是文本。然后需要将该值输入到具有“5. Exchanged”下拉值的单元格右侧的单元格 28 个单元格中。

第三个动作是……

When "6. Completed" is selected,an inputbox should popup requesting a "Purchase Price" and "Purchaser" value to be inputted ("Please insert a purchase price and a Purchaser").购买价格值将是一个 £ 数字，并且需要输入到具有“6. Completed”下拉值的单元格右侧的 23 个单元格中。购买者值将是一个文本值，需要输入到具有“6. Completed”下拉值的单元格右侧的 22 个单元格中。然后将整行复制并粘贴到名为“Deals Schedule”的工作表中的最后一行文本下。然后从源工作表中删除该行（称为 Disposals）。

我已经开始创建代码，但我迷路了，因为我只能从在线论坛拼凑出这么多东西。我对 VBA 的了解非常有限。

非常感谢任何帮助。

我在单独的行动上取得了一些成功，但不是作为一个整体。

我试过的代码如下

Private Sub Worksheet_Change(ByVal Target As Range)

Dim A As Range
Dim P As String
Set A = Range("B2:B9999")
If Intersect(Target, A) Is Nothing Then Exit Sub
If Target.Value = "4. Under Offer" Then
P = InputBox("please enter date")
ActiveCell.Activate
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = P

Else

If Target.Value = "5. Exchanged" Then
P = InputBox("please enter date")
ActiveCell.Activate
ActiveCell.Offset(0, 28).Activate
ActiveCell.Value = P


Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row

Else

If Target.Value = "6. Completed" Then

        P = InputBox("please enter a purchase price")
        ActiveCell.Activate
        ActiveCell.Offset(0, 23).Activate
        ActiveCell.Value = P

        P = InputBox("please enter purchaser")
        ActiveCell.Activate
        ActiveCell.Offset(0, 22).Activate
        ActiveCell.Value = P

         varResponse = MsgBox("Please confirm the status is 'complete'! Have you put in pricing information and purchaser? The data will be moved to the 'Deal Schedule' tab in red below..... Press 'Yes' To Proceed or 'No' To Cancel", vbYesNo, "Selection")
        If varResponse <> vbYes Then Exit Sub
        LR = Sheets("Deals Schedule").Range("A" & Rows.Count).End(xlUp).Row + 1
        Target.EntireRow.Copy
        Sheets("Deals Schedule").Range("A" & LR).PasteSpecial
        Flag = True
        Target.EntireRow.Delete
        End If

            End If


Application.CutCopyMode = False
Flag = False

End Sub

Answer 1

 Private Sub Worksheet_Change(ByVal Target As Range)
 Application.EnableEvents = False  'must stop reacting or we will get into a loop when we delete target below

Dim P As String

If Target.Column <> 2 Then 'only column B
    Application.EnableEvents = True
    Exit Sub
End If
Select Case Target.Text
    Case Is = "4. Under Offer"
        P = InputBox("please enter date")
        Target.Offset(0, 1) = P

   Case Is = "5. Exchanged"
        P = InputBox("please enter date")
        Target.Offset(0, 28) = P

    Case Is = "6. Completed"

        P = InputBox("please enter a purchase price")
        Target.Offset(0, 23) = P

        P = InputBox("please enter purchaser")

        Target.Offset(0, 22) = P
        Dim varResponse
         varResponse = MsgBox("Please confirm the status is 'complete'! Have you put in pricing information and purchaser? The data will be moved to the 'Deal Schedule' tab in red below..... Press 'Yes' To Proceed or 'No' To Cancel", vbYesNo, "Selection")
        If varResponse = vbYes Then
            Dim LR As Long
            LR = Sheets("Deals Schedule").Range("A" & Rows.Count).End(xlUp).Row + 1
            Target.EntireRow.Copy Sheets("Deals Schedule").Range("A" & LR)
            Target.EntireRow.Delete
        End If
End Select
Application.EnableEvents = True 'must turn the react back on


End Sub