Question

我刚刚写完这个Sub for Excel。我基本上要求我的最终用户总计（例如$3000）找到每个客户在列表上花费的总金额，并报告总数超过$3000的金额（由Report提供的金额用户）在我创建的名为Sub Userinput() Dim myValue As Variant myValue = InputBox("Give me some input") Range("E1").Value = myValue If (Len(myValue) < 0 Or Not IsNumeric(myValue)) Then MsgBox "Input not valid, code aborted.", vbCritical Exit Sub End If End Sub的新工作表上。

我到目前为止编写了这段代码，它也验证了用户输入的值：

Customer orders         

Order Date  Customer ID Amount purchased    
02-Jan-12   190         $580    
02-Jan-12   144         $570    
03-Jan-12   120         $1,911  
03-Jan-12   192         $593    
03-Jan-12   145         $332

有关如何使用输入值搜索客户数据库并查找输入内容以及将其放入新工作表中的任何建议？

编辑：数据样本：

{{1}}

Answer 1

试试这个

Sub Userinput()
    Dim cl As Range, cl2 As Range, key, myValue
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    myValue = InputBox("Give me some input")
    [E1].Value = "Amount Limit: " & myValue
    If (Len(myValue) < 0 Or Not IsNumeric(myValue)) Then
        MsgBox "Input not valid, code aborted.", vbCritical
        Exit Sub
    End If
    For Each cl In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
        If Not dic.exists(cl.Value) Then
            dic.Add cl.Value, Nothing
        End If
    Next cl
    Set cl = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
    Set cl2 = Range("C2:C" & Cells(Rows.Count, "B").End(xlUp).Row)
    [E2] = ""
    For Each key In dic
        If WorksheetFunction.SumIf(cl, key, cl2) > myValue Then
            If [E2] = "" Then
                [E2] = "Customer ID: " & key
            Else
                [E2] = [E2] & ";" & key
            End If
        End If
    Next key
    Set dic = Nothing
End Sub

输出

enter image description here

<强>更新

Sub Userinput()
    Dim cl As Range, cl2 As Range, key, myValue, i&
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    myValue = InputBox("Give me some input")
    With Sheets("Source")
        .[E1].Value = "Amount Limit: " & myValue
        If (Len(myValue) < 0 Or Not IsNumeric(myValue)) Then
            MsgBox "Input not valid, code aborted.", vbCritical
            Exit Sub
        End If
        myValue = CDec(myValue)
        For Each cl In .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
            If Not dic.exists(cl.Value) Then
                dic.Add cl.Value, Nothing
            End If
        Next cl
        Set cl = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        Set cl2 = .Range("C2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        Sheets("Destination").UsedRange.ClearContents
        Sheets("Destination").[A1] = "Customer ID": i = 2
        For Each key In dic
            If WorksheetFunction.SumIf(cl, key, cl2) > myValue Then
                Sheets("Destination").Cells(i, "A") = key: i = i + 1
            End If
        Next key
    End With
    Set dic = Nothing
End Sub

输出

enter image description here

Answer 2

你可以试试这个。我假设您需要复制到同一工作簿中的工作表

Option Explicit
Dim MyWorkbook As Workbook
Dim MyWorksheet As Worksheet
Dim MyOutputWorksheet As Worksheet

Sub Userinput()
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyWorksheet = MyWorkbook.Sheets("WorksheetName")
Set MyOutputWorksheet = MyWorkbook.Sheets("OutputWorksheetName")

    Dim myValue As Long
    Dim RowPointer As Long

    myValue = InputBox("Give me some input")
    MyWorksheet.Range("E1").Value = myValue

    'conditional checking
    If (Len(myValue) < 0 Or Not IsNumeric(myValue)) Then
        MsgBox "Input not valid, code aborted.", vbCritical
        Exit Sub
    End If

    For RowPointer = 2 To MyWorksheet.Cells(Rows.Count, "C").End(xlUp).Row
        If MyWorksheet.Range("C" & RowPointer).Value > MyWorksheet.Range("E1").Value Then
        MyWorksheet.Range(("A" & RowPointer) & ":C" & RowPointer).Copy Destination:=MyOutputWorksheet.UsedRange.Offset(1, 0)
        'MyOutputWorksheet.UsedRange.Offset(1, 0).Value = MyWorksheet.Rows(RowPointer, 1).EntireRow.Value
        End If
    Next RowPointer


End Sub

Answer 3

这是另一种方法，它利用直接Excel功能Copy客户ID列，RemoveDuplicates，SUMIF基于客户，Delete这些行最低限度。

Sub CopyFilterAndCountIf()

    Dim dbl_min As Double
    dbl_min = InputBox("enter minimum search")

    Dim sht_data As Worksheet
    Dim sht_out As Worksheet

    Set sht_data = ActiveSheet
    Set sht_out = Worksheets.Add()

    sht_data.Range("B:B").Copy sht_out.Range("A:A")
    sht_out.Range("A:A").RemoveDuplicates 1, xlYes

    Dim i As Integer
    For i = sht_out.UsedRange.Rows.Count To 2 Step -1
        If WorksheetFunction.SumIf( _
            sht_data.Range("B:B"), sht_out.Cells(i, 1), sht_data.Range("C:C")) < dbl_min Then
            sht_out.Cells(i, 1).EntireRow.Delete
        End If
    Next
End Sub

我没有对输入进行错误检查，但你可以添加它。我也利用Excel的意愿来处理整个列而不是处理查找范围。绝对可以更容易理解代码。

还应该提到的是，您可以通过使用带有Sum上的过滤器的数据透视表而不是VBA来完成所有这些相同的功能。

如何实现用户输入

3 个答案: