VBA required to delete some rows in each workbook

dxstudios · Sep 9th 2020

Hi Ozgrid Friends,

i m on seeking help regarding a manual task which i am doing..

here my task is like....i have Folder, which contains many workbooks, each workbook contains a

sheet called START, here in this START sheet, i need to checkout the B column

for the specific Word/ Approximate match "Not Required:"

if this word comes in B column, including that ROW & below ROWS has to be deleted from that sheet.

the same has to be done for all the workbooks in that folder.

in the attached sample workbook i have highlighed the ROWS in yellow, which has to be deleted.

Requesting someone Expert to help me on this Task.sample book.xlsx

**royUK** · Sep 9th 2020

Try this. You might want to change delete to select whilst testing.

Also, change the directory path in the code

Code

Sub DeleteRows()
Dim wbOpen As Workbook, wbNew As Workbook
Dim rCl As Range
''/// Change Path
Const strPath As String = "C:\Excel\"
Dim strExtension As String


With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual


On Error GoTo exit_proc


ChDir strPath
'Change extension
strExtension = Dir("*.xls*")
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
With wbOpen.Sheets("START")
Set rCl = .Cells.Find(What:="*Not Required*", After:=ActiveCell, LookIn:=xlFormulas2, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rCl Is Nothing Then .Range(rCl, .Cells(.Rows.Count, 2).End(xlUp)).EntireRow.Delete
.Close SaveChanges:=False
End With
strExtension = Dir
Loop
exit_proc:
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Display More

dxstudios · Sep 9th 2020

Sir, i have tried with your code, but its not happening, its opening the first file from the path & getting stopped.

could you please have a look on it.

Code

Sub DeleteRows()
Dim wbOpen As Workbook, wbNew As Workbook
Dim rCl As Range
''/// Change Path
Const strPath As String = "C:\Users\x\not req\"
Dim strExtension As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
On Error GoTo exit_proc
ChDir strPath
'Change extension
strExtension = Dir("*.xlsx*")
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
With wbOpen.Sheets("START")
Set rCl = .Cells.Find(What:="*Not Required*", After:=ActiveCell, LookIn:=xlFormulas2, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rCl Is Nothing Then .Range(rCl, .Cells(.Rows.Count, 2).End(xlUp)).EntireRow.Delete
.Close SaveChanges:=False
End With
strExtension = Dir
Loop
exit_proc:
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Display More

**royUK** · Sep 9th 2020

Try changing this

Code

strExtension = Dir("*.xlsx*")

to

Code

strExtension = Dir("*.xls*")

dxstudios · Sep 9th 2020

Yes i tried change the extension Sir, still the same issue...its opening the first file from the path & getting stopped.

attaching the folder.not req.zip not req.zip

**royUK** · Sep 9th 2020

Try this, I haven't time to check it but it should work

Code

Sub DeleteRows()
Dim oWb As Workbook
Dim rCl As Range
Dim sFil As String, strExtension As String
''/// check this
Const strPath As String = "C:\not req\"
''/// use error handler after checking
'On Error GoTo Reset
With Application
.ScreenUpdating = False
.EnableEvents = False


''///Target File Extension (must include wildcard "*")
strExtension = "*.xls*"


''///Target Path with Ending Extention
sFil = Dir(myPath & strExtension)


''///Loop through each Excel file in folder
Do While sFil <> ""
''///Set variable equal to opened workbook
Set oWb = Workbooks.Open(Filename:=myPath & sFil)


''///Ensure Workbook has opened before moving on to next line of code
DoEvents


With oWb
Set rCl = .Cells.Find(What:="*Not Required*", After:=ActiveCell, LookIn:=xlFormulas2, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rCl Is Nothing Then .Range(rCl, .Cells(.Rows.Count, 2).End(xlUp)).EntireRow.Delete
''///Save and Close Workbook
oWb.Close SaveChanges:=True
End With


''///Ensure Workbook has closed before moving on to next line of code
DoEvents
''///Get next file name
sFil = Dir
Loop
''///Message Box when tasks are completed
MsgBox "Done!"
Exit Sub
Reset:
.EnableEvents = True
.ScreenUpdating = True
End With


End Sub

Display More

dxstudios · Sep 9th 2020

my badluck

nothing happening Sir,

Just a message window appear & says "Done" but nothing gets changes in workbooks

Please have a look on it Sir.

**royUK** · Sep 9th 2020

Try this, it works for me. You ill be prompted to pick the folder then it will run through each workbook

Code

Sub DeleteRows()
Dim oWb As Workbook
Dim oWs As Worksheet
Dim rCl As Range
Dim sFil As String, strExtension As String, sPath As String
Dim FldrPicker As FileDialog
''/// use error handler after checking
'On Error GoTo Reset
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)


With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo cancelled
sPath = .SelectedItems(1) & "\"
End With


''///In Case of User Cancel
cancelled:
sPath = sPath
If sPath = "" Then GoTo Reset


''///Target File Extension (must include wildcard "*")
strExtension = "*.xls*"


''///Target Path with Ending Extention
sFil = Dir(sPath & strExtension)


''///Loop through each Excel file in folder
Do While sFil <> ""
''///Set variable equal to opened workbook
Set oWb = Workbooks.Open(Filename:=sPath & sFil)
''///Ensure Workbook has opened before moving on to next line of code
DoEvents


With oWb
Set oWs = oWb.Sheets("Start")
Set rCl = oWs.Range("B:B").Find(What:="*Not Required*", LookIn:=xlValues)
If Not rCl Is Nothing Then oWs.Range(rCl, oWs.Cells(oWs.Rows.Count, 2).End(xlUp)).EntireRow.Delete
''///Save and Close Workbook
oWb.Close SaveChanges:=True
End With


''///Ensure Workbook has closed before moving on to next line of code
DoEvents
''///Get next file name
sFil = Dir
Loop
''///Message Box when tasks are completed
MsgBox "Done!"
Exit Sub
Reset:
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With


End Sub

Display More

dxstudios · Sep 9th 2020

Awesome Sir, Now it worked perfectly as expected

Thank you so much for your Help Sir

dxstudios · Sep 9th 2020

Hi Sir,

Few things to get clarified.....

1) if i need to add one more word to check , like "Not Required" & "Not checked"...How to do that?

2) some of the sheet names are slightly different, instead of "START" it is updated as "START "

a space at the last makes the code to get stopped there...please help me to resolve it Sir

**royUK** · Sep 9th 2020

Are the sheets always in the same position i.e. the first sheet n the workbook?

**royUK** · Sep 9th 2020

Actually try this

Code

Sub DeleteRows()
Dim oWb As Workbook
Dim oWs As Worksheet
Dim rCl As Range
Dim sFil As String, strExtension As String, sPath As String
Dim FldrPicker As FileDialog
''/// use error handler after checking
'On Error GoTo Reset
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)


With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo cancelled
sPath = .SelectedItems(1) & "\"
End With


''///In Case of User Cancel
cancelled:
sPath = sPath
If sPath = "" Then GoTo Reset


''///Target File Extension (must include wildcard "*")
strExtension = "*.xls*"


''///Target Path with Ending Extention
sFil = Dir(sPath & strExtension)


''///Loop through each Excel file in folder
Do While sFil <> ""
''///Set variable equal to opened workbook
Set oWb = Workbooks.Open(Filename:=sPath & sFil)
''///Ensure Workbook has opened before moving on to next line of code
DoEvents


With oWb
For Each oWs In oWb.Worksheets
If oWs.Name Like "Start*" Then Set rCl = oWs.Range("B:B").Find(What:="*Not *", LookIn:=xlValues)
If Not rCl Is Nothing Then oWs.Range(rCl, oWs.Cells(oWs.Rows.Count, 2).End(xlUp)).EntireRow.Delete
''///Save and Close Workbook
oWb.Close SaveChanges:=True
Next oWs


Set rCl = oWs.Range("B:B").Find(What:="*Not*", LookIn:=xlValues)
If Not rCl Is Nothing Then oWs.Range(rCl, oWs.Cells(oWs.Rows.Count, 2).End(xlUp)).EntireRow.Delete
''///Save and Close Workbook
oWb.Close SaveChanges:=True
End With


''///Ensure Workbook has closed before moving on to next line of code
DoEvents
''///Get next file name
sFil = Dir
Loop
''///Message Box when tasks are completed
MsgBox "Done!"
Exit Sub
Reset:
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With


End Sub

Display More

You have probably noticed that you are getting a privacy warning, you can fix this using this tip Remove The Personal Information Warning

dxstudios · Sep 9th 2020

Quote from royUK

Are the sheets always in the same position i.e. the first sheet n the workbook?

Yes Sir, the sheet always comes in the first position.

dxstudios · Sep 9th 2020

i tried with the updated code also......getting stopped at the location of

Code

If oWs.Name Like "Start*" Then Set rCl = oWs.Range("B:B").Find(What:="*Not *", LookIn:=xlValues)

dxstudios · Sep 9th 2020

Quote from dxstudios

i tried with the updated code also......getting stopped at the location of

sorry, i m getting error at this location

Code

Set rCl = oWs.Range("B:B").Find(What:="*Not *", LookIn:=xlValues)

**royUK** · Sep 9th 2020

Sorry, I didn't check properly. I'm busy upgrading my own web site.

This should work now

Code

Sub DeleteRows()
Dim oWb As Workbook
Dim oWs As Worksheet
Dim rCl As Range
Dim sFil As String, strExtension As String, sPath As String
Dim FldrPicker As FileDialog
''/// use error handler after checking
'On Error GoTo Reset
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)


With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo cancelled
sPath = .SelectedItems(1) & "\"
End With


''///In Case of User Cancel
cancelled:
sPath = sPath
If sPath = "" Then GoTo Reset


''///Target File Extension (must include wildcard "*")
strExtension = "*.xls*"


''///Target Path with Ending Extention
sFil = Dir(sPath & strExtension)


''///Loop through each Excel file in folder
Do While sFil <> ""
''///Set variable equal to opened workbook
Set oWb = Workbooks.Open(Filename:=sPath & sFil)
''///Ensure Workbook has opened before moving on to next line of code
DoEvents


With oWb
For Each oWs In .Worksheets
If oWs.Name Like "Start*" Then Set rCl = oWs.Range("B:B").Find(What:="*Not *", LookIn:=xlValues)
If Not rCl Is Nothing Then oWs.Range(rCl, oWs.Cells(oWs.Rows.Count, 2).End(xlUp)).EntireRow.Delete
''///Save and Close Workbook
.Close SaveChanges:=True
Next oWs
End With


''///Ensure Workbook has closed before moving on to next line of code
DoEvents
''///Get next file name
sFil = Dir
Loop
''///Message Box when tasks are completed
MsgBox "Done!"
Exit Sub
Reset:
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With


End Sub

Display More

dxstudios · Sep 9th 2020

i m extremely sorry for Disturbing you in middle of your work Sir,

i tried with the updated code, now no error appears, just running til the end, but there is no changes in any of the workbooks,

i m attaching the folder for your reciew Sir.

not req.zip

dxstudios · Sep 10th 2020

Sir, code almost working fine on all the files, only below things to be added to it.

1) if i need to add one more word to check , like "Not Required" & "TAT"(this one is newly added)...How to do that sir?

2) some of the sheet names are slightly different, instead of "START" it is updated as "START "

a blank space at the end of sheet names making some troubles, is it possible to remove spaces at the end of sheet name.

FYI...this sheet name (START) always comes at first position.

Excuse me Sir ..if i m going very lengthy.... can i start the above request in a new post ?

**royUK** · Sep 10th 2020

Try this

Code

Sub DeleteRows()
Dim oWb As Workbook
Dim oWs As Worksheet
Dim rCl As Range
Dim sFil As String, strExtension As String, sPath As String
Dim sArr(1 To 2) As String
Dim iX As Integer
Dim FldrPicker As FileDialog




sArr(1) = "Not Required"
sArr(2) = "TAT"
''/// use error handler after checking
'On Error GoTo Reset
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)


With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo cancelled
sPath = .SelectedItems(1) & "\"
End With


''///In Case of User Cancel
cancelled:
sPath = sPath
If sPath = "" Then GoTo Reset


''///Target File Extension (must include wildcard "*")
strExtension = "*.xls*"


''///Target Path with Ending Extention
sFil = Dir(sPath & strExtension)


''///Loop through each Excel file in folder
Do While sFil <> ""
''///Set variable equal to opened workbook
Set oWb = Workbooks.Open(Filename:=sPath & sFil)
''///Ensure Workbook has opened before moving on to next line of code
DoEvents


With oWb
Set oWs = oWb.Worksheets(1)
For iX = LBound(sArr) To UBound(sArr)
Set rCl = oWs.Range("B:B").Find(What:=sArr(iX), LookIn:=xlValues)
Next iX
If Not rCl Is Nothing Then oWs.Range(rCl, oWs.Cells(oWs.Rows.Count, 2).End(xlUp)).EntireRow.Delete
''///Save and Close Workbook
.Close SaveChanges:=True
End With


''///Ensure Workbook has closed before moving on to next line of code
DoEvents
''///Get next file name
sFil = Dir
Loop
''///Message Box when tasks are completed
MsgBox "Done!"
Exit Sub
Reset:
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With


End Sub

Display More

dxstudios · Sep 10th 2020

Worked Like a Charm

Just Saying Thank You will never repay your kindness Sir.

i really appreciate your patience in replying to all threads posted in this forum

can you please share your Webpage link Sir.

VBA required to delete some rows in each workbook

Participate now!

Share

Users Viewing This Thread