Delete data records with a specific value in Column E in each worksheet of several files

Dear Experts:

I happen to come across this code snippet that does what I would like to have in just the active sheet:

Hence this code is the basis that needs to be re-written so that the deletion is completed on all worksheets of all the excel-files in C:\MyData

Help is much appreciated. Thank you very much in advance.

Regards, Andreas

Sub Delete_NZ_From_ActiveSheet()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Dim lastrow As Long, r As Long
   lastrow = ActiveSheet.UsedRange.Rows.Count
   For r = lastrow To 1 Step -1
      If UCase(Cells(r,5).Value) = "NZ" Then Rows(r).Delete
   Next r
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
End Sub

Select allOpen in new window

Hi Rob,

no, every sheet needs to be worked on. There are a couple of excel files that are protected. They should be omitted.

Regards, Andreas

Hi Rob,

thank you very much for your swift and professional help. Works great!

Maybe someone is able to come up with a solution ...
... to loop thru all the files in folder C:\MyData and perform the above actions.

Again, thank you very much for your great support.

Regards, Andreas

hi Andreas,

Are there any subfolders in C:\MyData & if so, should they be searced for excel files too?


(another) Rob

Hi Rob,

works like a charm. I am truly impressed. Thank you very much for your professional and superb help.

You asked if subfolders also should be searched. Now it turns out that I got cases where this is the case.

Do you think you could rewrite your code so that it also permits searching in subfolders. That would be great.

Thank you very much, Regards, Andreas

hi Andreas,


Will it be every excel file in the main "C:\MyData" folder & every excel file in the sub folders too?
If it is always going to be every file that gets processed then I'll change the code so that you don't need to manually select the files. However, if you prefer for the user to do this selection, or if there could be exemptions, then I'll figure out a way to keep the macro looping until all possible sub folders have been viewed/checked/selected from.

Rob

hi,

Here's a rough & ready version that I have copied & pasted together from other projects. It's still not thoroughly tested, but it did run from start to finish for me. Run the "Delete_NZ_From_ActiveSheet_v3" sub & let me know if I'm on the right track...

Option Explicit

Public glb_origCalculationMode As Long
Public glb_origStatusBar As String
Public FirstTimeListingSubFolders As Boolean
Public ListSubFolders As VbMsgBoxResult
Public ListAllDetails As VbMsgBoxResult
Public fs As Object, f As Object

Sub Delete_NZ_From_ActiveSheet_v3()
'modified from my OpenManyFiles_v2()
Const strPath As String = "C:\MyData"    '"C:\Users\Robert\Documents"
Dim OriPath As String   ' Original path
Dim sFname As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim LastCll As Range
Dim AFRng As Range
Dim VisRows As Range
Dim i As Long
Dim r As Long

    Call ToggleRefreshXlApp(False)
    'identify the current directory & then change it to the desired path before using getopen filename
    OriPath = CurDir
    ChDir strPath
    'or    ChDir ThisWorkbook.Path
    '    sFname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)

    'this will delete any existing sheet from previous running of the macro
    If DoesSheetExist("List of Files") Then
        Application.DisplayAlerts = False
        ThisWorkbook.Worksheets("List of Files").Delete
        Application.DisplayAlerts = True
    End If

    Call ListFilesAndFolders

    With ThisWorkbook.Worksheets("List of Files")
        sFname = .Range(.Cells(6, "b"), .Cells(.Cells(.Rows.Count, "b").End(xlUp).Row, "b"))
    End With

    If IsArray(sFname) Then
        For i = LBound(sFname) To UBound(sFname)
            '  test that the file name is for an excel file
            If InStr(1, sFname(i, 1), ".xls") Then
                Set wb = Workbooks.Open(Filename:=sFname(i, 1), UpdateLinks:=False)
                For Each ws In wb.Worksheets
                    Set LastCll = LastCell(ws)
                    With ws
                        'remove any filters & turn the autofilter back on
                        If .AutoFilterMode Then
                            .AutoFilterMode = False
                        End If

                        Set AFRng = .Range(.Cells(1, 1), LastCll)
                        With AFRng
                            .AutoFilter Field:=5, Criteria1:="NZ"
                            'set a range variable to the visible rows after applying the filter, test that some rows exist & delete them
                            On Error Resume Next
                            Set VisRows = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible).EntireRow
                            On Error GoTo 0
                            If Not VisRows Is Nothing Then
                                VisRows.Delete Shift:=xlUp
                            End If
                            .AutoFilter Field:=5
                        End With
                    End With
                    Set LastCll = Nothing
                    Set VisRows = Nothing
                    Set AFRng = Nothing
                Next ws
                wb.Close True
                Set wb = Nothing
                'do nothing
            End If
        Next i
    End If

    'change back to user's original path
    ChDir OriPath
    Call ToggleRefreshXlApp(True)
    MsgBox "Done"
End Sub

Sub RefreshXlApp()
    With Application
        .EnableEvents = True
        On Error Resume Next
        .Calculation = xlCalculationAutomatic
        On Error GoTo 0
        .StatusBar = False
        .ScreenUpdating = True
        .DisplayFormulaBar = True
        .ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
    End With
End Sub
Sub ToggleRefreshXlApp(RefreshAppSettings As Boolean, Optional ByRef xlApp As Excel.Application)
    If xlApp Is Nothing Then
        Set xlApp = Excel.Application
    End If
    With xlApp
        If Not RefreshAppSettings Then
            glb_origCalculationMode = .Calculation
            glb_origStatusBar = .StatusBar
        End If
        .EnableEvents = RefreshAppSettings
        On Error Resume Next
        '        .Calculation = IIf(RefreshAppSettings, glb_origCalculationMode, xlCalculationManual)
        .Calculation = IIf(RefreshAppSettings, xlCalculationAutomatic, xlCalculationManual)
        On Error GoTo 0
        .StatusBar = IIf(RefreshAppSettings, vbNullString, CBool(glb_origStatusBar))
        .ScreenUpdating = RefreshAppSettings
    End With
    Set xlApp = Nothing
End Sub

Function DoesSheetExist(shtName As String, Optional wkb As Workbook = Nothing) As Boolean
'1/06/2010, sourced from: http://www.excelforum.com/excel-programming/731229-reference-a-sheet-that-may-or-may-not-exist.html
    On Error Resume Next
    DoesSheetExist = Not IIf(wkb Is Nothing, ActiveWorkbook, wkb).Sheets(shtName) Is Nothing
    On Error GoTo 0
End Function


Sub ListFilesAndFolders()
Dim RequestedDirectory As String
Dim N As Long
Dim ConvertToHyperlinks As VbMsgBoxResult
Dim ListingWs As Worksheet

    ''gather user input at start of macro
    'ListSubFolders = MsgBox("Do you want to list the files in the sub folders?", vbYesNo, "LIST THE FILES IN THE SUB FOLDERS?")
    ListSubFolders = vbYes

    'ConvertToHyperlinks = MsgBox("do you want to convert the files listed to hyperlinks?", vbYesNo)
    ConvertToHyperlinks = vbNo

    ''identify if all details are required to be listed - this will be slower.
    'ListAllDetails = MsgBox("Press [yes] to list all details or [no] for just the file & folder names", vbYesNo)
    ListAllDetails = vbNo

    '    Call ToggleRefreshXlApp(False)
    'insert & name a new sheet
    Set ListingWs = ThisWorkbook.Worksheets.Add
    With ListingWs
        .Name = "List of Files"
        .Range(.Cells(5, 1), .Cells(5, 2)) = Array("Folder", "File")
        Select Case ListAllDetails
            Case Is <> vbYes
                'leave blank
            Case Is = vbYes
                .Range(.Cells(5, 3), .Cells(5, 8)) = Array("Size", "Type", "Date Created", "Date Last Accessed", "Date Last Modified", "Attributes")
        End Select
    End With
    'GetFolder is sourced from p 370 & ListFiles sourced from p769 of Excel 2002 Power Programming with VBA
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = CurDir
        .Title = "Please choose folder to list files from"
        .Show
        If .SelectedItems.Count = 0 Then MsgBox "no folder selected": Exit Sub
        RequestedDirectory = .SelectedItems(1)
    End With
    ''The GetSubDirectories subroutine is called recursively using the name of the parent folder.
    Call GetSubDirectories(RequestedDirectory, ListSubFolders)
    ''Hyperlinks (formulae not just cell formatting using [ctrl + k] due to occasional issues) are added to all entries in columns 1 & 2
    ''other background info 3/4's down the following sheet http://www.mvps.org/dmcritchie/excel/sheets.htm
    ''Q: can this be done in one hit w/o looping?
    ''A: appears not!
    With ListingWs
        Select Case ConvertToHyperlinks
            Case Is <> vbYes
                'no action
            Case Is = vbYes
                For N = 6 To .Cells(.Rows.Count, 1).End(xlUp).Row
                    With .Cells(N, 1)
                        .Value = "=hyperlink(" & Chr(34) & .Value & Chr(34) & ", " & Chr(34) & .Value & Chr(34) & ")"
                        With .Offset(0, 1)
                            .Value = "=hyperlink(" & Chr(34) & .Value & Chr(34) & ", " & Chr(34) & .Value & Chr(34) & ")"
                        End With
                    End With
                Next N
        End Select
        .Columns.AutoFit
    End With
    Set fs = Nothing
    Set f = Nothing
    '    MsgBox "done"
    '    Call ToggleRefreshXlApp(True)
End Sub
Sub GetSubDirectories(folderspec, ListSubFolders As VbMsgBoxResult)
Dim SubFolder As Object       'not sure what this sould be?
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Call GetFiles(f.Path, ListAllDetails)
    Select Case ListSubFolders
        Case Is = vbYes        'value = 6
            For Each SubFolder In f.SubFolders
                Call GetSubDirectories(SubFolder.Path, ListSubFolders)        'This is a recursive call
            Next SubFolder
        Case Else        'case is = 7 'vbno or False or Case Is = 2 'vbcancel or Cancelled
    End Select
End Sub
Sub GetFiles(folderspec, ListAllDetails As VbMsgBoxResult)
Dim r As Long
Dim file As Object
    ReDim TempArr(1 To 1, 1 To 8) As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    On Error Resume Next
    For Each file In f.Files
        On Error Resume Next
        r = Range("A" & Rows.Count).End(xlUp).Row + 1
        TempArr(1, 1) = folderspec
        TempArr(1, 2) = folderspec & "\" & file.Name
        Select Case ListAllDetails
            Case Is <> vbYes
                'leave blank
            Case Is = vbYes
                With file
                    TempArr(1, 3) = .Size
                    TempArr(1, 4) = .Type
                    TempArr(1, 5) = .DateCreated
                    TempArr(1, 6) = .DateLastAccessed
                    TempArr(1, 7) = .DateLastModified
                    TempArr(1, 8) = .Attributes
                End With
        End Select
        Range(Cells(r, 1), Cells(r, 8)).Value2 = TempArr
        On Error GoTo 0
    Next file
End Sub

Function LastCell(ws As Excel.Worksheet) As Excel.Range
'22/09/2013, RB: written as "Function AttemptAtARobustLastCellFinder_v4(ws As Worksheet) As Range" for:
'http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39474286
'inspired by FP's comments about a "binary chop" approach http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380467
'still subject to the limitations of CountA which Qlemo mentioned: http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380520

Dim PercentArr As Variant    'this can probably be written better
Dim PercentageMultiplier As Double
Dim PercentInd As Long    'percent loop index
Dim LastRow As Long
Dim LastCol As Long
Dim RowsInWs As Long
Dim ColsInWs As Long
Dim LoopInd As Long
Dim UpperLim As Long
Dim BlockSizer As Long
Dim FirstRowOfUsedRng As Long

    With ws
        RowsInWs = .Rows.Count
        ColsInWs = .Columns.Count
    End With
    PercentArr = Array(0.5, 0.3, 0.1, 0.05, 0.03, 0.01, 0.005, 0.003, 0.001, 1)

    'run a loop to find the last row
    'v4, amended in case the first row of the used range is not Row 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(RowsInWs, .Cells(1, 1).Row - 1 + .Rows.Count)
    End With

    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * RowsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                If Application.CountA(ws.Range(LoopInd - BlockSizer + 1 & ":" & LoopInd)) Then
                    Exit For
                End If
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastRow = Application.WorksheetFunction.Max(1, UpperLim)

    'run a loop to find the last column
    'v4, amended in case the first column of the used range is not column 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(ColsInWs, .Cells(1, 1).Column - 1 + .Columns.Count)
    End With
    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * ColsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                With ws
                    'Searches entire columns
                    'v4 corrected as per http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39392583
                    If Application.CountA(.Range(.Cells(1, LoopInd - BlockSizer + 1), .Cells(RowsInWs, LoopInd))) Then
                        Exit For
                    End If
                End With
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastCol = Application.WorksheetFunction.Max(1, UpperLim)

    '    'User feedback for testing
    Debug.Print "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address
    '    MsgBox "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address

    Set LastCell = ws.Cells(LastRow, LastCol)
End Function

Select allOpen in new window

hth
Rob

Hi Rob,

wow, the code keeps growing and growing ... Incredible. I'll do some testing soon and then let you know. Regards, Andreas.

thank you very much for your superb help.

Regards, andreas

hi Andreas,

hmmm, more code doesn't necessarily mean better!
It could be written a lot better, some of the reason that this is so long is purely because I copied & pasted from my old work & haven't made it streamlined.

Let me know how your testing goes.

Rob

Hi Rob,

it is throwing an error message on line 118: A modul has a type that is not permitted (translated from English).

Rob, you know what, do not bother to trap the error / adjust the code. I am so happy with the first code you sent me (it is superfast), i.e. the one that does not do subfolders. As a matter of fact, I can easily circumvent this problem.

Again thank you very much for your great help.

Regards, Andreas

hi Andreas,

I'm just guessing here, do you have the code in a "sheet module"?

If you move all the code to a "normal" module I think the error will stop occurring.

Rob

I normally never integrate codes into a sheet module, but I will double check ...

Hi Rob, nope, sorry, I did not integrate it into a sheet module.

Anyway, you deserve most of the points for your first macro you provided. It works like a charm.

Regards, Andreas

Mod's: This post is not an objection.

hi Andreas,
I'm sorry I can't help more... but I don't want to give up yet.
Is line 118 which is erroring the one that  states "Function DoesSheetExist(shtName As String, Optional wkb As Workbook = Nothing) As Boolean"?
Does the code compile when you put it into the VBE & then press [alt + d + l]?
I'd like to see if I can replicate the error message. What language are you using in your Regional & Language Settings (an option within the Control Panel)?


Rob

Dear both,

this forum is so great. I have never walked away from this forum without a very good solution.
Thank you very much for your great and professional help.

Regards, Andreas

Thank you for the points Andreas :-)

Hi Rob,

thank you very much for your post about not giving up.

I will re-test over the coming days and then let you know.

Regards, Andreas