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

Question

好的，这就是场景，

我有 4 个标准：

1. 区
2. 最高价格
3. 最小尺寸
4. 房间

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

1. 选择的区（整数）是否是客户选择的那个
2. 如果价格（整数）小于最高价格
3. 如果大小大于最小大小（整数）
4. 如果房子有客户选择的房间数（整数）。

如果工作表（OnSale）上列表中的数据符合上述要求，它将首先创建一个表格，然后按照以下添加符合上述所有条件的房屋的详细信息。 （项目|单位数量|价格|价格（psf）|价格（psm）|尺寸（平方米）|卧室|使用权）（在OnSale上找到）

最后，如果表格没有结果，我需要它自动删除新工作表并通知用户当前没有此类销售。

提前致谢！

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

    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

正如我在上面的 cmets 中提到的，您可以使用 Autofilter 来获得所需的结果。我已经详细注释了代码，但是如果您有任何问题，请在 cmets 中提问：)

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