Question : Filter, Add New Sheet, Delete All Sheets

Hi Experts,

I need 2 VBA for the following purposes:

1) VBA Append: A vba which will be filtering records based on the E column and ADD a new sheets based on every unique value and name the new sheet based on the filtered value and paste the visible cells on that sheet.

VBA will loop through the Column E and create sheets based on the filtered value now the second part is VBA Delete:

VBA Delete: Will be deleting all sheets except "qryConsolidate", "Sheet1" and "Sheet2"

Please let me know in case you need further information on this. Thank you.

Answer : Filter, Add New Sheet, Delete All Sheets

Here are the two codes you need.

Thomas

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:

           
           
             Sub SplitListIntoWorksheets()
'split list into individual worksheets
Dim lastRow As Long, i As Long, j As Long, arrComp(0 To 2000) As Variant 'define variables
Dim shtData As Worksheet, shtDest As Worksheet
application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes
 
With Sheets("qryConsolidate")
 
    lastRow = .range("E" & Rows.Count).End(xlUp).Row 'get last row
    
    Set shtData = Sheets("qryConsolidate") 'ActiveSheet
    
    j = 0
    
    For i = 2 To lastRow
        If .Cells(i, "E") <> .Cells(i - 1, "E") Then
            arrComp(j) = .Cells(i, "E")
            j = j + 1
        End If
    Next
 
End With
 
For i = 0 To j - 1
    shtData.AutoFilterMode = False
    shtData.range("$A$1").CurrentRegion.AutoFilter FIELD:=5, Criteria1:=arrComp(i)
    Set shtDest = Sheets.Add
    shtDest.Name = arrComp(i)
    shtData.range("$A$1").CurrentRegion.Copy
    ActiveSheet.Paste
Next
 
application.ScreenUpdating = True 'reenable ScreenUpdating
 
End Sub
 
Sub DeleteAllSheetsBut()
Dim sht As Worksheet
 
application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Sheets
    If sht.Name <> "Sheet1" And _
        sht.Name <> "Sheet2" And _
        sht.Name <> "qryConsolidate" Then _
            sht.Delete
Next
application.DisplayAlerts = True
 
End Sub
           
         

Open in New Window

Select All