VBA required to keep specific sheets & rest all to be deleted

dxstudios · Sep 12th 2020

Hi friends,

i have a folder with bulk files in it, Here my task is

STEP1: I need to open each & every file & check the sheet name called START, in this sheet E column cells contains text as PROCEED & also other texts,

i just need this entire row to be highlighted if the cell contains word PROCEED.

STEP2:

Then i need to go for B column in same sheet &

here B column contains the sheet names (sheetA,sheetB,sheet1....etc)

as per the sheet names in B column, the workbook also contains the sheets in the same names.

Now i need to keep the sheets, only which are highlighted in above STEP1, rest all sheets can be deleted.

Now the same process has to be repeated for the entire files in that folder.

for better understanding i have attached the sample workbooks & manually higlighted some ROWS

also changed the sheet name in RED, which are need & rest all to be deleted.

i know its a big ask, but i m requesting some experts to help me.

Thanks in Advance.not req.zip

**royUK** · Sep 12th 2020

I answered almost the same question for you, that code needs adapting. I f you want to learn VBA then have a go.

davesexcel · Sep 12th 2020

Check it out.

Note: Nothing like wasting an hour on a question that was already answer in a previous thread.

Code

Sub LoopThroughFolder()
 
    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Rws As Long, rng As Range
    '--------------------
    Dim sh As Worksheet
    Dim c As Range, ws As Worksheet
    Dim s As String, x
    
    '---------------------
    Set Wb = ThisWorkbook
    'change the address to suite
    MyDir = "C:\Users\davem\OneDrive\Excel Examples\not req\"
    MyFile = Dir(MyDir & "*.xlsx")               'change file extension
    ChDir MyDir
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    Do While MyFile <> ""
        Workbooks.Open (MyFile)
        '-----------------------
        Set ws = Sheets("START")
        With ws
            Rws = .Cells(Rows.Count, "E").End(xlUp).Row
            Set rng = Range(.Cells(2, "E"), .Cells(Rws, "E"))
            For Each c In rng.Cells
                If c Like "*Proceed*" Then
                    c.EntireRow.Interior.Color = vbGreen
                End If
            Next c
            
            For Each sh In Sheets
                s = sh.Name
                If sh.Name <> ws.Name Then
                    x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), s)
                    If x = 0 Then sh.Delete
                End If
            Next sh
            '----------------------------
            ActiveWorkbook.Close True
        End With
        MyFile = Dir()
    Loop
 
End Sub

Display More

dxstudios · Sep 12th 2020

Thank you Sir, it worked perfectly

it helps me a lot for my learning.

dxstudios · Sep 12th 2020

Quote from royUK

I answered almost the same question for you, that code needs adapting. I f you want to learn VBA then have a go.

Sir, i m sorry , i m very new to VBA coding.....just started learning by recording & playing back the macros...

then learning from your solution threads, your comment in codes are helpfull to me.....

due to some office worloads i cant learn it full time

i hope in somedays i will learn & try on my own....Thank you Sir

dxstudios · Sep 12th 2020

Code

Sub LoopThroughFolder()

 Dim MyFile As String, Str As String, Wb As Workbook
 Dim Rws As Long, rng As Range
 '--------------------
 Dim sh As Worksheet
 Dim c As Range, ws As Worksheet
 Dim s As String, x
 Dim MyDir As String, fn As String, i As Long, e, flg As Boolean
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then MyDir = .SelectedItems(1) & "\"
    End With
    If MyDir = "" Then Exit Sub
 '---------------------
 Set Wb = ThisWorkbook
 'change the address to suite
 'MyDir = "C:\Users\davem\OneDrive\Excel Examples\not req\"
 MyFile = Dir(MyDir & "*.xlsx") 'change file extension
 ChDir MyDir
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 
 Do While MyFile <> ""
 Workbooks.Open (MyFile)
 '-----------------------
 Set ws = Sheets("START")
 With ws
 Rws = .Cells(Rows.Count, "E").End(xlUp).Row
 Set rng = Range(.Cells(2, "E"), .Cells(Rws, "E"))
 For Each c In rng.Cells
 If c Like "*Proceed*" Then
 c.EntireRow.Interior.ColorIndex = 16
 End If
 Next c
 
 For Each sh In Sheets
 s = sh.Name
 If sh.Name <> ws.Name Then
 x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), s)
 If x = 0 Then sh.Delete
 End If
 Next sh
 '----------------------------
 ActiveWorkbook.Close True
 End With
 MyFile = Dir()
 Loop
 MsgBox "Unwanted Sheets Removed from All files!"
End Sub

Display More

dxstudios · Sep 12th 2020

Code

 If x = 0 Then sh.Visible = False

instead of delete i tried to Hide, it worked

dxstudios · Sep 21st 2020

Code

For Each sh In Sheets
 s = sh.Name
 If sh.Name <> ws.Name Then
 x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), s)
 If x = 0 Then sh.Delete
 End If
 Next sh

Sir,

Here the code looks for the sheet name with Exact names in range (B:B)

is it possible to find the approximate matches?

for example:

if the name appears as Sheet1 in B:B & sheet name comes as Sheet1-Approved

since the sheet name contains additional words (-Approved) in its names, code not considering it.

Please Help me Sir.

davesexcel · Sep 21st 2020

You could try this, I haven't tested it.

Code

x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), "*" & s & "*")

**royUK** · Sep 21st 2020

Dave's suggestion should work, but if you are deleting sheets you will get a warning before the deletion. You can avoid the warning by using Application.DisplayAlerts like this.

Code

For Each sh In Sheets
s = sh.Name
If sh.Name <> ws.Name Then
x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), "*" & s & "*")
Application.DisplayAlerts = False
If x = 0 Then sh.Delete
Application.DisplayAlerts = True
End If
Next sh

dxstudios · Sep 21st 2020

Thank you so much for quick reply Both of you Sir,

i just checked with the code....but not no luck still the same ....

i m attaching the sample workbook & screenshot.

Kindly have a look on it Sir.

not req (2).zip not req (2).zip

dxstudios · Sep 21st 2020

Sir,

Instead of Delete, i m using Hide option.

Code

 For Each sh In Sheets
 s = sh.Name
 If sh.Name <> ws.Name Then
 x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), "*" & s & "*")
 ''x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), s)
  If x = 0 Then sh.Visible = False
 End If
 Next sh

**royUK** · Sep 21st 2020

Use very hidden, it's more secure because code is needed to unhide it

Code

If x = 0 Then sh.Visible = xlsheetveryhidden

Which workbook contains the code that you are using?

dxstudios · Sep 21st 2020

Thank you Sir,

I replaced below line of code, working fine, but how to check that hidden sheets manually

Code

If x = 0 Then sh.Visible = xlsheetveryhidden

dxstudios · Sep 21st 2020

Quote from royUK

Which workbook contains the code that you are using?

Sir, i m running code by opening a new xl sheet & personal workbook macro....i m running these codes

**royUK** · Sep 22nd 2020

Then I need to see that code

dxstudios · Sep 22nd 2020

Quote from royUK

Then I need to see that code

this is the code i m using it in personal workbook Sir

Code

Sub LoopThroughFolder()

Dim MyDir As String, fn As String, i As Long, e, flg As Boolean
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then MyDir = .SelectedItems(1) & "\"
    End With
    If MyDir = "" Then Exit Sub
 
 Dim MyFile As String, Str As String, Wb As Workbook
 Dim Rws As Long, rng As Range
 '--------------------
 Dim sh As Worksheet
 Dim c As Range, ws As Worksheet
 Dim s As String, x
 
 '---------------------
 Set Wb = ThisWorkbook
 'change the address to suite
 'MyDir = "C:\Users\f\Desktop\not req\"
 MyFile = Dir(MyDir & "*.xlsx") 'change file extension
 ChDir MyDir
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 
 Do While MyFile <> ""
 Workbooks.Open (MyFile)
 '-----------------------
 Set ws = Sheets("START")
 With ws
 Rws = .Cells(Rows.Count, "E").End(xlUp).Row
 Set rng = Range(.Cells(2, "E"), .Cells(Rws, "E"))
 For Each c In rng.Cells
 If c Like "*Proceed*" Then
 c.EntireRow.Interior.ColorIndex = 16
 End If
 Next c
 
 For Each sh In Sheets
 s = sh.Name
 If sh.Name <> ws.Name Then
 x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), "*" & s & "*")
 ''x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), s)
  If x = 0 Then sh.Visible = xlSheetVeryHidden
 End If
 Next sh
 '----------------------------
 ActiveWorkbook.Close True
 End With
 MyFile = Dir()
 Loop
 MsgBox "Unwanted Sheets Removed from All files!"
End Sub

Display More

**royUK** · Sep 22nd 2020

Try this, from what I can see you need to explicitly state which workbook to work with

Code

Option Explicit


Sub LoopThroughFolder()


Dim MyDir As String, fn As String, i As Long, e, flg As Boolean
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then MyDir = .SelectedItems(1) & "\"
End With
If MyDir = "" Then Exit Sub


Dim MyFile As String, Str As String
Dim Rws As Long, rng As Range
'--------------------
Dim sh As Worksheet
Dim c As Range, ws As Worksheet
Dim s As String, x As Integer


'---------------------




Application.ScreenUpdating = False
Application.DisplayAlerts = False
'change the address to suite
'MyDir = "C:\Users\f\Desktop\not req\"
MyFile = Dir(MyDir & "*.xlsx") 'change file extension
ChDir MyDir




Do While MyFile <> ""
Workbooks.Open (MyFile)
'-----------------------
Set ws = ActiveWorkbook.Sheets("START")
With ws
Rws = .Cells(Rows.Count, "E").End(xlUp).Row
Set rng = Range(.Cells(2, "E"), .Cells(Rws, "E"))
For Each c In rng.Cells
If c Like "*Proceed*" Then
c.EntireRow.Interior.ColorIndex = 16
End If
Next c


For Each sh In ActiveWorkbook.Sheets
s = sh.Name
If sh.Name <> ws.Name Then
x = Application.WorksheetFunction.CountIf(ws.Range("B:B"), "*" & s & "*")
If x = 0 Then sh.Visible = xlSheetVeryHidden
End If
Next sh
'----------------------------
ActiveWorkbook.Close True
End With
MyFile = Dir()
Loop


MsgBox "Unwanted Sheets Removed from All files!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Display More

dxstudios · Sep 22nd 2020

i tried with the above code Sir, still the same issue ....SheetA-Approved getting hided,

here i am attaching that sheet ..workbook sample (1).xlsx

**royUK** · Sep 22nd 2020

It looks like your code will delete SheetA,SheetB,SheetC and Sheet1

VBA required to keep specific sheets & rest all to be deleted

Participate now!

Share

Tags

Users Viewing This Thread