Question

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

第一个动作是..

当选择“ 4. Under Offer”时，将弹出一个输入框，要求输入“日期”值（“请输入要出售的房产的日期”）。该值可能是日期，但有时只是文本。然后需要使用“ 4. Under Offer”下拉值将值直接输入到单元格右侧的单元格中。

第二个动作是...

选择“ 5.交换”时，将弹出一个输入框，要求输入“日期”值（“请在交换属性中插入日期”）。该值可能是日期，但有时只是文本。然后需要将该值输入到单元格右侧具有28个单元格的下拉菜单中的“ 5. Exchanged”下拉值。

第三个动作是...

当选择“ 6.完成”时，应弹出一个输入框，要求输入“购买价格”和“购买者”值（“请输入购买价格和购买者”）。购买价格值将是£英镑，需要输入到该单元格右侧23个单元格中的“ 6. Completed”下拉值中。购买者值将是文本值，并且需要使用“ 6. Completed”下拉值将其输入到该单元格右边的22个单元格中。然后将整行复制并粘贴到称为“交易时间表”的工作表的最后一行文本下。然后将该行从源工作表中删除（称为“处置”）。

我已经开始创建代码，但是我迷路了，因为我只能从在线论坛上拼凑很多东西。我对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

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

1 个答案: