Question

我试过在这个网站上查找，但找不到太相似的东西。我要做的是询问用户输入他们想要搜索的目标值。然后，我希望程序循环遍历销售数据，并且对于找到的每个值都大于用户输入，将这些数据复制到新的工作表中。

Sub Task1()
Dim LastRow As Integer, i As Integer, erow As Integer
Dim wsnew As Worksheet
Dim userInput As Long
Dim compare As Integer


LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
userInput = InputBox("Enter a value to search for:")

Set wsnew = Worksheets.Add(after:=Worksheets(Worksheets.Count))
wsnew.name = "Report"
Worksheets("Report").Range("A1").Value = "Dollar sales over $" & userInput
Worksheets("Report").Range("A1").Font.Bold = True

For i = 2 To LastRow
    compare = Cells(i, 3).Value
    If compare > userInput Then
        Range(Cells(i, 1), Cells(i, 3)).Select
        Selection.Copy
        Worksheets("Report").Select
        erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ActiveSheet.Cells(erow, 1).Select
        ActiveSheet.Paste
    End If
Next i

End Sub

Answer 1

未经测试，写在手机上。

如果您乐意分配工作表/范围来存储条件，也可以使用AutoFilter或高级过滤器。

Option explicit

Sub Task1()
Dim LastRow As long
Dim SourceSheet As Worksheet
Dim DestinationSheet
Dim userInput As Long

Set SourceSheet = ActiveSheet

LastRow = SourceSheet.Range("A" & Rows.Count).End(xlUp).Row
' You could specify type argument below to limit to numeric types and for basic validation.'
userInput = InputBox("Enter a value to search for:")

Set DestinationSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))

With DestinationSheet
.name = "Report"
With .Range("A1")
.Value2 = "Dollar sales over $" & userInput
.Font.Bold = True
End with

' Minimise interactions with worksheet. '
Dim RawValues() as variant
RawValues = SourceSheet.range("A2:C" & lastrow).value2

Dim FilteredValues() as variant
Redim FilteredValues(lbound(RawValues,1) to ubound(RawValues,1), lbound(RawValues,2) to ubound(RawValues,2))

' 3 = column C. Change line below if it changes. '
Const COMPARISON_COL_NUM as long = 3

Dim WriteIndex as long
Dim RowIndex as long
Dim ColumnIndex as long
Dim ColumnUbound as long
ColumnUbound= ubound(FilteredValues,2) ' instead of re-determining for each row '

For RowIndex = lbound(RawValues,1) to ubound(RawValues,1)

If RawValues(RowIndex COMPARISON_COL_NUM) > userinput then

WriteIndex = WriteIndex + 1
For ColumnIndex = 1 to ColumnUbound
FilteredValues(WriteIndex,ColumnIndex) = RawValues(RowIndex, ColumnIndex)
Next ColumnIndex

End if

Next RowIndex

' You could Redim Preserve FilteredValues to 1 to WriteIndex, 1 to ColumnUbound, so that you get rid of empty rows, but you would have to transpose the array first. '

'Write only values back to sheet. '
With range("A2").resize(ubound(FilteredValues,1),ubound(FilteredValues,2))
.value2 = FilteredValues

' Assumes cell formatting does not differ from row to row on the source sheet.
SourceSheet.range("A2:C2").copy
.pastespecial xlpasteformats
Application.cutcopymode = false

End with

End with


End Sub

循环销售数据并将销售额超过一定数量的新工作表

1 个答案: