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

好的，这是一个场景

我有4个标准：

地区

最高价格

最小尺寸

房间

我有一个数据列表，其中列出了工作表（OnSale）上所需的所有值，我只需要在这两者之间运行特定的算法来整理这些条件：

选择的地区（整数）是否为客户端选择的地区

如果价格（整数）小于最大价格

如果大小大于最小大小（整数）

如果房屋拥有客户选择的房间数（整数）

如果工作表（OnSale）列表中的数据符合上述要求，它将首先创建一个表，然后添加符合上述所有标准的住宅详细信息，如下所示。（项目|单元号|价格|价格（psf）|价格（psm）|面积（平方米）|卧室|使用期限）（可在网上找到）

---

最后，如果表没有结果，我需要它自动删除新表，并通知用户当前没有此类销售 正如我在上面的评论中提到的，您可以使用

Autofilter

来获得所需的结果。我已经对代码进行了详细的注释，但如果您有一些问题，请在注释中提问：）

Sub finddata（）
模糊区域作为字符串
Dim maxPrice为长，minSize为整数，room为整数，finalRow为长
将sh设置为工作表
作为范围的Dim数据
变暗rng As范围
'尝试获取工作表（如果存在）
出错时继续下一步
设置sh=图纸（“阿拉卡萨姆”）
错误转到0
'如果它不存在-创建它
如果sh什么都不是
设置sh=thiswook.Worksheets.Add
sh.Name=“阿拉卡萨姆”
如果结束
sh.Range（“A2:M”和Rows.Count）.ClearContents
“获取标准
带工作表（“RealEstateAmigo！”）
地区=.范围（“T4”）.值
maxPrice=.Range（“T5”）.值
minSize=.Range（“T6”）.值
房间=.范围（“T7”）.值
以
带床单（“出售”）
finalRow=.Range（“A”&.Rows.Count）.End（xlUp）.Row
设置数据=.Range（“A1:M”和finalRow）
'清除所有以前的筛选器
.AutoFilterMode=False
'应用筛选器以匹配标准
有数据
.自动筛选字段：=1，标准1:=地区
.自动筛选字段：=3，标准1:=“”（&M）
.自动筛选字段：=7，标准1:=“=”&房间
'尝试获取符合条件的可见行-行
出错时继续下一步
设置rng=.Offset（1）.调整大小（.Rows.Count-1）.特殊单元格（xlCellTypeVisible）
错误转到0
如果rng不算什么，那么
'如果未找到任何内容-显示错误消息+删除工作表
MsgBox“没有与所有标准匹配的行”
Application.DisplayAlerts=False
sh.删除
Application.DisplayAlerts=True
其他的
'如果找到数据-复制到工作表ALAKASAM
数据。行（1）。复制
sh.Range（“A1”）.Paste特殊XLPaste值
sh.Range（“A1”）.Paste特殊XLPaste格式
'复制标题
收到
sh.Range（“A2”）.Paste特殊XLPaste值
sh.Range（“A2”）.Paste特殊XLPaste格式
Application.CutCopyMode=False
sh.选择
如果结束
以
'禁用所有筛选器
.AutoFilterMode=False
以
端接头

您可以查看要将结果粘贴到哪张表中？哦，谢谢，我已经更改了！但它仍然不起作用：（正如我看到的，您总是清除sheet

Sheets（“Alakazam”）.Range（“A2:M1048576”）.ClearContents

，所以正如我看到的，代码应该总是从A2单元格开始粘贴结果。这是真的吗？正如我从这里看到的

。粘贴特殊的XLPasteFormulas和NumberFormats

您尝试粘贴公式。也许您需要粘贴值？嘿，simoco，只是想知道是否也可以粘贴单元格的格式？

    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

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