Question

好的，这是一个场景，

我有4个标准：

区
最高价格
最小尺寸
房间

我有一个数据列表，表明工作表（OnSale）上所需的所有值我只需要在其间运行某些算法来整理这些标准：

区（整数）是否选择是客户选择的
如果价格（整数）小于最大价格
如果大小大于最小尺寸（整数）
如果房子有客户选择的房间数（整数）。

最后，如果表格没有结果，我需要它自动删除新表格并告知用户当前没有这样的销售。＆lt; - 可能是MsgBox。我真的希望有人可以帮助我解决这个问题，我对VBA真的很陌生并需要让这些事情发生:(如果有人可以提供帮助，我会非常感激。

提前致谢！

到目前为止我到达的地方但代码没有给我带来任何结果

    Option Explicit

Sub finddata()

Dim district As String
Dim maxPrice As Long
Dim minSize As Integer
Dim room As Integer
Dim finalRow As Integer
Dim i As Integer

Sheets("Alakazam").Range("A2:M1048576").ClearContents

district = Sheets("RealEstateAmigo!").Range("T4").Value
maxPrice = Sheets("RealEstateAmigo!").Range("T5").Value
minSize = Sheets("RealEstateAmigo!").Range("T6").Value
room = Sheets("RealEstateAmigo!").Range("T7").Value
finalRow = Sheets("OnSale").Range("A10000").End(xlUp).Row

For i = 2 To finalRow               'to loop & check every single value
    If Cells(i, 1) = district Then  ' if district match
        If Cells(i, 3) < maxPrice Then  'if less than MaxPrice
            If Cells(i, 6) > minSize Then 'if greater than minSize
                If Cells(i, 7) = room Then  ' if room number match
                    Range(Cells(i, 1), Cells(i, 13)).Copy 'Copy the rows
                    Sheets("Alakazam").Range("A2").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
                End If
            End If
        End If
    End If
Next i

Sheets("Alakazam").Select
Sheets("Alakazam").Range("A2").Select


End Sub

Answer 1

正如我在上面的评论中提到的，您可以使用Autofilter来获得所需的结果。我已详细评论了代码，但如果您有问题，请在评论中提问：）

Sub finddata()

    Dim district As String
    Dim maxPrice As Long, minSize As Integer, room As Integer, finalRow As Long
    Dim sh As Worksheet

    Dim data As Range
    Dim rng As Range

    'try to get sheet if it exist
    On Error Resume Next
    Set sh = Sheets("Alakazam")
    On Error GoTo 0
    'if it not exist - create it
    If sh Is Nothing Then
        Set sh = ThisWorkbook.Worksheets.Add
        sh.Name = "Alakazam"
    End If

    sh.Range("A2:M" & Rows.Count).ClearContents
    'get criterias
    With Sheets("RealEstateAmigo!")
        district = .Range("T4").Value
        maxPrice = .Range("T5").Value
        minSize = .Range("T6").Value
        room = .Range("T7").Value
    End With

    With Sheets("OnSale")
        finalRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set data = .Range("A1:M" & finalRow)
        'clear all previous filters
        .AutoFilterMode = False
        'apply filters to match criterias
        With data
            .AutoFilter Field:=1, Criteria1:=district
            .AutoFilter Field:=3, Criteria1:="<" & maxPrice
            .AutoFilter Field:=6, Criteria1:=">" & minSize
            .AutoFilter Field:=7, Criteria1:="=" & room
            'try to get visible rows - thouse that matches criteria
            On Error Resume Next
            Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0

            If rng Is Nothing Then
                'if nothing found - show error message + delete sheet
                MsgBox "There is no rows matched all criterias"
                Application.DisplayAlerts = False
                sh.Delete
                Application.DisplayAlerts = True
            Else
                'if data found - copy to sheet Alakazam
                data.Rows(1).Copy
                sh.Range("A1").PasteSpecial xlPasteValues
                sh.Range("A1").PasteSpecial xlPasteFormats
                'copy headers
                rng.Copy
                sh.Range("A2").PasteSpecial xlPasteValues
                sh.Range("A2").PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                sh.Select
            End If
        End With
        'disable all filters
        .AutoFilterMode = False
    End With

End Sub

VBA提取所有相关数据并进行排序和验证

1 个答案: