Reputation: 65
Ok here's the scenario,
I have 4 Criteria:
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 :
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
Upvotes: 2
Views: 712
Reputation: 35853
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
Upvotes: 1