VBA Extracting all relevant data and sorting plus validation - excel

Ok here's the scenario,
I have 4 Criteria:
District
Max Price
Min Size
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 :
Whether the district(integer) chose is the one the client chose
If the Price(Integer) is lesser than the Max Price
If the size is greater than the Min Size (Integer)
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

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

Related

VBA to copy specific cells from one worksheet to another upon meeting a criteria

My VBA knowledge is very limited, so looking for some help here. Tried some Googling and putting together a code but hasn't met the goal. Appreciate the help here!
I have 2 worksheets:
Data - source worksheet with the data to be copied
Dashboard - Target sheet for pasting
Data sheet - It has multiple columns, the ones I have named are the ones I need to be copied except the column named "Sold?" which is for criteria. The other columns with no names in the image actually have data, to avoid confusion I have removed them here.
This sheet grows and I will add a new row of data when needed.
Dashboard Sheet - When I click "Refresh" button, I want the code to check the "Data" sheet and if a row meets of criteria of Sold? = "N", then only data from column C,G,J,M should be copied and pasted into columns B,C,D,E of "Dashboard" sheet. Additional criteria: if an investment name repeats, the details need to be summed up and shown in Dashboard sheet. I have provided my expected output in the image. (ABC & TY summed up)
I have tried a bit but unable to incorporate all the criteria and this code when run doesn't throw an error but does nothing, no output.
Private Sub Refresh_Click()
Worksheets("Dashboard").Activate
Application.ScreenUpdating = True
a = Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
For i = 12 To a
If Worksheets("Data").Cells(i, 15).Value = "N" Then
Worksheets("Data").Cells(i, 3).Copy
Worksheets("Data").Cells(i, 7).Copy
Worksheets("Data").Cells(i, 13).Copy
Worksheets("Data").Cells(i, 14).Copy
Worksheets("Dashboard").Activate
Worksheets("Dashboard").Range("B6:G25").Select
ActiveSheet.Paste
End If
Next
Application.CutCopyMode = False
End Sub
I strongly suggest a pivot table. Still if you want VBA based solution, you might try this code:
Option Explicit
Private Sub Refresh_Click()
'Declarations.
Dim BlnHiddenColumns() As Boolean
Dim DblFirstRow As Double
Dim DblLastRow As Double
Dim DblCounter01 As Double
Dim DblCounterLimit01 As Double
Dim DblInvestmentNameColumn As Double
Dim DblQuantityColumn As Double
Dim DblAfterChargeColumn As Double
Dim DblCurrentPLColumn As Double
Dim DblSoldColumn As Double
Dim RngData As Range
Dim RngResult As Range
Dim StrAutofilterAddress As String
Dim StrMarker As String
Dim StrInvestmentNameHeader As String
Dim StrQuantityHeader As String
Dim StrAfterChargeHeader As String
Dim StrCurrentPLHeader As String
Dim WksData As Worksheet
Dim WksDashboard As Worksheet
Dim WksPivotTable As Worksheet
Dim PvtPivotTable01 As PivotTable
'Settings.
DblInvestmentNameColumn = 3
DblQuantityColumn = 7
DblAfterChargeColumn = 10
DblCurrentPLColumn = 13
DblSoldColumn = 15
DblFirstRow = 12
DblCounterLimit01 = 1000
StrMarker = "N"
Set WksData = Worksheets("Data")
DblLastRow = WksData.Cells(Rows.Count, "B").End(xlUp).Row
Set RngData = WksData.Range(WksData.Cells(DblFirstRow - 1, Excel.WorksheetFunction.Min(DblInvestmentNameColumn, DblQuantityColumn, DblAfterChargeColumn, DblCurrentPLColumn, DblSoldColumn)), WksData.Cells(DblLastRow, Excel.WorksheetFunction.Max(DblInvestmentNameColumn, DblQuantityColumn, DblAfterChargeColumn, DblCurrentPLColumn, DblSoldColumn)))
ReDim BlnHiddenColumns(1 To RngData.Columns.Count)
Set WksDashboard = Worksheets("Dashboard")
Set RngResult = WksDashboard.Range("B6")
StrInvestmentNameHeader = WksDashboard.Range("B5").Value
StrQuantityHeader = WksDashboard.Range("C5").Value
StrAfterChargeHeader = WksDashboard.Range("D5").Value
StrCurrentPLHeader = WksDashboard.Range("E5").Value
'Turning off screen updating.
Application.ScreenUpdating = False
'Checking for any previous results list.
If Excel.WorksheetFunction.CountBlank(RngResult) <> RngResult.Cells.Count Then
DblCounter01 = 0
'Checking each row of the result list until an entirely blank row is found.
Do Until Excel.WorksheetFunction.CountBlank(RngResult.Offset(DblCounter01, 0)) = RngResult.Cells.Count
DblCounter01 = DblCounter01 + 1
'If the number of rows checked is equal or superior to DblCounterLimit01 the macro is terminated.
If DblCounter01 >= DblCounterLimit01 Then
MsgBox "Please clear the current holdings list manually", vbCritical + vbOKOnly, "Unable to clear the current list"
Exit Sub
End If
Loop
'Clearing the list.
RngResult.Parent.Range(RngResult, RngResult.Offset(DblCounter01 - 1)).ClearContents
End If
'Checking for existing autofilter in WksData.
If WksData.AutoFilterMode = True Then
'Coping the address of the autofilter in WksData.
StrAutofilterAddress = WksData.AutoFilter.Range.Address
End If
'Removing any autofilter in WksData.
WksData.AutoFilterMode = False
'Covering each column of RngData.
For DblCounter01 = 1 To RngData.Columns.Count
'Setting BlnHiddenColumns accordingly to the RngData columns' status (hidden/not hidden).
BlnHiddenColumns(DblCounter01) = RngData.Columns(DblCounter01).Hidden
'Hiding the columns of RngData we won't copy.
Select Case DblCounter01 + RngData.Column - 1
Case Is = DblInvestmentNameColumn, DblQuantityColumn, DblAfterChargeColumn, DblCurrentPLColumn
RngData.Columns(DblCounter01).Hidden = False
Case Else
RngData.Columns(DblCounter01).Hidden = True
End Select
Next
'Filtering RngData.
RngData.AutoFilter Field:=DblSoldColumn - RngData.Column + 1, Criteria1:=StrMarker
'Copying the filtered RngData into RngResult.
RngData.Resize(RngData.Rows.Count - 1, RngData.Columns.Count).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy RngResult
'Restoring the RngData columns to their previous status (hidden/not hidden).
For DblCounter01 = 1 To RngData.Columns.Count
If BlnHiddenColumns(DblCounter01) Then
RngData.Columns(DblCounter01).Hidden = True
Else
RngData.Columns(DblCounter01).Hidden = False
End If
Next
'Removing any autofilter in WksData.
WksData.AutoFilterMode = False
'Restoring any pre-existing autofilter in WksData.
If StrAutofilterAddress <> "" Then
WksData.Range(StrAutofilterAddress).AutoFilter
End If
'Setting RngResult to cover the imported list (headers included).
Set RngResult = RngResult.Offset(-1, 0)
Set RngResult = WksDashboard.Range(RngResult, RngResult.End(xlDown).End(xlToRight))
'Creating WksPivotTable.
Set WksPivotTable = Sheets.Add
'Creating PvtPivotTable01.
Set PvtPivotTable01 = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=RngResult, _
Version:=7 _
).CreatePivotTable(TableDestination:=WksPivotTable.Cells(1, 1), _
TableName:="Temporary Pivot Table", _
DefaultVersion:=7 _
)
'Setting PvtPivotTable01.
With PvtPivotTable01.PivotFields(StrInvestmentNameHeader)
.Orientation = xlRowField
.Position = 1
End With
With PvtPivotTable01
.AddDataField .PivotFields(StrQuantityHeader), "Sum of " & StrQuantityHeader, xlSum
.AddDataField .PivotFields(StrAfterChargeHeader), "Sum of " & StrAfterChargeHeader, xlSum
.AddDataField .PivotFields(StrCurrentPLHeader), "Sum of " & StrCurrentPLHeader, xlSum
.ColumnGrand = False
End With
'Clearing the data from RngResult.
RngResult.Offset(1, 0).Resize(RngResult.Rows.Count - 1).ClearContents
'Copying the PvtPivotTable01 content to RngResult.
PvtPivotTable01.DataBodyRange.Offset(0, -1).Resize(, PvtPivotTable01.DataFields.Count + 1).Copy RngResult.Cells(2, 1)
'Deleting WksPivotTable.
Application.DisplayAlerts = False
WksPivotTable.Delete
Application.DisplayAlerts = True
'Restoring screen updating.
Application.ScreenUpdating = False
End Sub
I've intentionally made it longer than the necessary, especially by creating many variables to avoid hard coded data. This method might be useful in more complex and/or longer codes.

Delete rows with multiple criteria in VBA

my goal is to delete rows with column 3 with the cell value that has inventory (>0) and column 4 that has the cell value TRUE in the current sheet. I tried to use the code to this website and I'm pretty sure I did something wrong where it says ActiveSheet.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Public Sub FilterStock()
ActiveSheet.Range("A1").AutoFilter Field:=4, Criteria1:="TRUE"
ActiveSheet.Range("A1").AutoFilter Field:=3, Criteria1:=">0"
Application.DisplayAlerts = False
ActiveSheet.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.AutoFilter.ShowAllData
End Sub
This code worked for me:
Sub DeletelRows()
Dim lastRow As Long
Dim debug1 As Variant
Dim debug2 As Variant
'Find the last non-blank cell in column C
lastRow = Cells(Rows.Count, 3).End(xlUp).Row
For x = lastRow To 2 Step -1 'Start at bottom and go up to avoid complications when the row is deleted.
debug1 = Cells(x, 3).Value 'You can set breakpoints to see what the values are.
debug2 = Cells(x, 4).Value
If (Cells(x, 3).Value > 0 And UCase(Cells(x, 4).Value) = "TRUE") Then
Rows(x).Delete
End If
Next x
End Sub

Deleting Multiple Rows based on a Set Criteria

Sub Macro()
Dim i As Long
For i = Cells(Rows.Count, 14).End(xlUp).Row To 2 Step -1
If Cells(i, 14).Value2 = "APPLE" Then
Rows(i).Delete
End If
Next i
Dim f As Long
For f = Cells(Rows.Count, 14).End(xlUp).Row To 2 Step -1
If Cells(f, 14).Value2 = "NAME" Then
Rows(f).Delete
End If
Next f
End Sub
I have the above mentioned code to delete all the rows that have apple and name on them, If possible I would like excel to execute the code in one or two lines. Your help would be greatly appreciated!
Dim i As Long
For i = Cells(Rows.Count, 14).End(xlUp).Row To 2 Step -1
IF Cells(i, 14).Value2 = "APPLE" OR Cells(i, 14).Value2 = "NAME" THEN Rows(i).Delete
Next i
The fast way to delete rows is using AutoFilter:
Sub FastDelete()
Dim rng As Range, rngVisible As Range
'//Remove filter if any
ActiveSheet.AutoFilterMode = False
'// Get range of only one column (N)
Set rng = Range(Cells(1, 14), Cells(Rows.Count, 14).End(xlUp))
'// Field:=1 because filter has only one field
rng.AutoFilter Field:=1, Criteria1:=Array("APPLE", "NAME"), Operator:=xlFilterValues
'// Have error handling in case if no data is found
On Error Resume Next
With rng
'// Use Offset and Resize to exclude header
Set rngVisible = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
End With
'// If rows were found (i.e. there's no error), delete them
If Err = 0 Then rngVisible.EntireRow.Delete
On Error GoTo 0
'// Remove filter
ActiveSheet.AutoFilterMode = False
End Sub

Copy rows in Excel if cell contains name from an array

I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub

run macro on AutoFilter and show data in new sheet

Actually what i want to do , i have following data With Auto Filtering ,
-> I want to create new sheet for each unique Name selected from filtering .i.e. if John and Alex are selected then 2 new sheets should be created one for John and second for Alex , and each of them show own data (Name + No + R). When Next time if master sheet get updated then news data should be appended when i run macro. i'm using following code but its not working 100%.
Sub mycar()
x = 2
Do While Cells(x, 1) <> ""
If Cells(x, 1) = "John" Then
Worksheets("Sheet1").Rows(x).Copy
Worksheets("Sheet2").Activate
eRow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(eRow)
End If
Worksheets("Sheet1").Activate
x = x + 1
Loop
End Sub
-> Here it copy only single data Written in the quotes.
-> Second time if i run this code , it is appending same data again with new data.
Help me to avoid this mistakes.
Thank you.
As discussed there is other possibility to set filter parameters in Array in procedure. The code would look like this one:
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Arkusz1") 'or other reference to data sheet
Dim shNew As Worksheet
shData.Activate
'get unique values based on Excel features
Range("a1").AutoFilter
Dim myArr As Variant
myArr = Array("John", "max")
Range("a1").AutoFilter
Dim i As Long
For i = 0 To UBound(myArr)
shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _
Operator:=xlAnd
On Error Resume Next
Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i)
Err.Clear
End If
Next i
'removing filter in master sheet
shData.Range("a1").AutoFilter
End Sub
Substitute Worksheets("Sheet1").Rows(x).Copy by Worksheets("Sheet1").Rows(x).EntireRow.Copy
And clear the destination worksheet before adding information.
I do quite similar exercise quite often. Therefore I provide full possible solution with some comments inside the code. It works for all unique values in column A and creates (if not exists) sheet with appropriate name equals to filter parameters.
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Arkusz1") 'or other reference to data sheet
Dim shNew As Worksheet
'get unique values based on Excel features
'i guess some will not like it but I do :)
Range("a1").AutoFilter
Range("A1").CurrentRegion.Columns(1).Copy Range("ww1")
Range("ww1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
'be sure that range where you copy (like ww1) is empty range around
Dim myArr As Variant
myArr = Range(Range("ww2"), Range("ww2").End(xlDown))
Range("ww1").CurrentRegion.ClearContents 'some cleaning
Range("a1").AutoFilter '
Dim i As Long
For i = 1 To UBound(myArr, 1)
ActiveSheet.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i, 1), _
Operator:=xlAnd
On Error Resume Next
'this is for two reason- to check if appropriate sheet exists, if so to clean top area
'if you need to append you would comment this line
Sheets(myArr(i, 1)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
'if you need to append only you would need to set range-to-copy a bit different
Range("A1").CurrentRegion.Copy Sheets(myArr(i, 1)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i, 1)
Err.Clear
End If
Next i
End Sub
This could not fully meet your requirements but could be a complete solution to improve accordingly.
Heading ##Below code is as per your requirement. Modify it based upon your requirement.
Private Sub Worksheet_Calculate()
Dim x As Integer
Dim rnge As Integer
x = Range(Selection, Selection.End(xlDown)).Count
rnge = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count
If Range("E1").Value > rnge Then
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets(2).Select
ActiveSheet.Paste
End If
End Sub

Resources