Question

Ok here's the scenario,

I have 4 Criteria:

  1. District
  2. Max Price
  3. Min Size
  4. Rooms

I've got a list of data that all the values required on a worksheet(OnSale) i just need to run certain algorithm in between to sort out these criteria :

  1. Whether the district(integer) chose is the one the client chose
  2. If the Price(Integer) is lesser than the Max Price
  3. If the size is greater than the Min Size (Integer)
  4. If the house has the number of rooms (Integer) that the client choose.

If the data within the list on the worksheet(OnSale) matches the requirements above, it will first create a table then add the details of the home that fits all the criteria above as per below. (Project|Unit Number|Price|Price(psf)|Price(psm)|Size (sqm)|BedRooms|Tenure) (Found on OnSale)

Lastly, If the table churns no results i need it to delete the new sheet automatically and inform the user that there's no such sale currently. <-- Possibly MsgBox. I really hope someone can help me with this cus i'm really new to VBA and need to make these things happen :( Would really appreciate it if someone could help.

Thanks in advance!

Here's where i got to so far but the code doesnt churn me any results in

    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
Was it helpful?

Solution

As I mentioned in comments above, you can use Autofilter to get desired result. I've commented code in details, but if you have some questions, ask in comments:)

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
Licensed under: CC-BY-SA with attribution
Not affiliated with StackOverflow
scroll top