VBA Извлечение всех соответствующих данных и сортировка плюс проверка

Хорошо, вот сценарий,

У меня есть 4 критерия:

  1. Округ
  2. Максимальная цена
  3. Минимальный размер
  4. Номера

У меня есть список данных, в которых все значения требуются на листе (OnSale), мне просто нужно запустить определенный алгоритм между ними, чтобы отсортировать эти критерии:

  1. Является ли выбранный район (целое число) тем, который выбрал клиент
  2. Если цена (целое число) меньше максимальной цены
  3. Если размер больше, чем минимальный размер (целое число)
  4. Если в доме есть количество комнат (Целое число), которое выбирает клиент.

Если данные в списке на рабочем листе (OnSale) соответствуют вышеуказанным требованиям, сначала будет создана таблица, а затем добавлены сведения о доме, который соответствует всем вышеуказанным критериям, как показано ниже. (Проект|Номер квартиры|Цена|Цена(psf)|Цена(psm)|Площадь (кв.м)|Спальни|Владение) (Найдено в OnSale)

Наконец, если таблица не дает результатов, мне нужно, чтобы она автоматически удаляла новый лист и информировала пользователя о том, что в настоящее время такой продажи нет. ‹-- Возможно 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

sorting excel vba extraction
person Monster123    schedule 15.03.2014    source источник
comment
вы можете просмотреть автофильтр   -  person Dmitry Pavliv    schedule 15.03.2014
comment
в какой лист вы собираетесь вставить результат?   -  person Dmitry Pavliv    schedule 15.03.2014
comment
О, спасибо, я уже поменял! но все равно не работает :(   -  person Monster123    schedule 15.03.2014
comment
как я вижу, вы всегда очищаете лист Sheets("Alakazam").Range("A2:M1048576").ClearContents, поэтому, как я вижу, код должен всегда вставлять результат, начиная с ячейки A2. Это правда?   -  person Dmitry Pavliv    schedule 15.03.2014
comment
Последнее, прежде чем я опубликую ответ - If the table churns no results i need it to delete the new sheet automatically - какой лист следует удалить?   -  person Dmitry Pavliv    schedule 15.03.2014
comment
как я вижу отсюда .PasteSpecial xlPasteFormulasAndNumberFormats вы пытаетесь вставить формулы. Может быть, вам нужно вставить значения?   -  person Dmitry Pavliv    schedule 15.03.2014
comment
Я не слишком уверен в синтаксисе для вставки значений, не могли бы вы показать мне, что я должен заменить .PasteSpecial xlPasteFormulasAndNumberFormats на ?   -  person Monster123    schedule 15.03.2014

Ответы (1)


arrow_upward
1
arrow_downward

Как я упоминал в комментариях выше, вы можете использовать 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
person Dmitry Pavliv    schedule 15.03.2014
comment
эй simoco, просто интересно, можно ли также вставить форматы ячеек? - person Monster123; 15.03.2014