VBA to identify files has No highlighted in Green in particular column

Hi,

Is there any VBA code that can help me Identify if files has no highlighted in Grean in Particular Column which is in Column B row 1 only. Because I have a hundreds of files to open each to validate if each files has green highlighted.

It is possible to create a checkfile on which files doesn't have a green Highlighted.
For example a created checkfile has a column "Filename of the file on which don't have a green highlighted" just a file name of it.


Hope you can help me with this. thanks in advance.

I have attached a 2 sample files (Sample 1 has a greenhighted and sample 2 doesn't have green highlighted), in this case the macro will create a file and has a column which tells you on what filename of the file doesn't have a green hightlighted.


Thanks again!

Should you search all sheets in each workbook or just the first one?

Artik

Only in first Sheet. Some files has different sheet name but we need to check only the first sheet in the file.

Try:

Sub Test()
    Dim vFiles      As Variant
    Dim v           As Variant
    Dim MsoAS       As MsoAutomationSecurity
    Dim Wb          As Workbook
    Dim oDicNoHighlighted As Object

    vFiles = GetFilesInFolder(CurDir & "\", 1, "Excel files", "*.xls*")

    If UBound(vFiles) < 0 Then
        Exit Sub
    End If

    MsoAS = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable
    Application.ScreenUpdating = False

    Set oDicNoHighlighted = CreateObject("Scripting.Dictionary")

    For Each v In vFiles
        Set Wb = Application.Workbooks.Open(v)
        
        With Wb.Worksheets(1)

            If .Range("B1").Interior.Color <> 5287936 Then
            'or
            'If .Range("B1").Interior.ColorIndex <> 14 Then
                oDicNoHighlighted.Add v, 0
            End If

        End With

        Wb.Close False
    Next v


    Application.AutomationSecurity = MsoAS


    If oDicNoHighlighted.Count > 0 Then
        v = oDicNoHighlighted.Keys()
        v = Application.Transpose(v)
        
        With Application.Workbooks.Add(Template:=xlWBATWorksheet)
            With .Worksheets(1).Range("A1").Resize(UBound(v))
                .Value = v
                .EntireColumn.AutoFit
            End With
        End With

    End If
    
End Sub



Function GetFilesInFolder(InitDir As String, FltrIndex As Long, ParamArray vFilers() As Variant) As Variant

    Dim sInitPath   As String
    Dim FDial       As Office.FileDialog
    Dim vrtSelectedItem As Variant
    Dim oDic        As Object
    Dim i           As Long

    If Len(InitDir) = 0 Then
        sInitPath = CurDir
    Else
        sInitPath = InitDir
    End If

    Set FDial = Application.FileDialog(msoFileDialogFilePicker)

    With FDial
        .Title = "Select files to check"
        .AllowMultiSelect = True

        .InitialFileName = sInitPath
        .Filters.Clear

        For i = LBound(vFilers) To UBound(vFilers) Step 2
            .Filters.Add vFilers(i), vFilers(i + 1)
        Next i

        .FilterIndex = FltrIndex

        If .Show <> -1 Then
            GetFilesInFolder = Array()
        Else
            Set oDic = CreateObject("Scripting.Dictionary")
            For Each vrtSelectedItem In .SelectedItems
                oDic.Add vrtSelectedItem, 0
            Next

            If oDic.Count = 0 Then
                GetFilesInFolder = Array()
            Else
                GetFilesInFolder = oDic.Keys()
            End If
        End If

    End With

End Function

Artik

This is perfect! however it is possible to open all the files from the main folder and well as with the sub folder. Because of the files are in the main folder but also has a sub folder?

Hope this is possible.

You are my lifesaver! thanks in advance again!

Try this:

Sub Test_2()
    Dim vFiles      As Variant
    Dim v           As Variant
    Dim MsoAS       As MsoAutomationSecurity
    Dim Wb          As Workbook
    Dim strRootFolder As String
    Dim oDicNoHighlighted As Object

    strRootFolder = GetFolder()
    
    If Len(strRootFolder) = 0 Then Exit Sub

    Call ListFiles(strRootFolder, vFiles, "[!~]*.xls*", True)

    If IsEmpty(vFiles) Then
        Exit Sub
    End If

    MsoAS = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable
    Application.ScreenUpdating = False

    Set oDicNoHighlighted = CreateObject("Scripting.Dictionary")

    For Each v In vFiles
        Set Wb = Application.Workbooks.Open(v)

        With Wb.Worksheets(1)

            If .Range("B1").Interior.Color <> 5287936 Then
                'or
                'If .Range("B1").Interior.ColorIndex <> 14 Then
                oDicNoHighlighted.Add v, 0
            End If

        End With

        Wb.Close False
    Next v


    Application.AutomationSecurity = MsoAS


    If oDicNoHighlighted.Count > 0 Then
        v = oDicNoHighlighted.Keys()
        v = Application.Transpose(v)

        With Application.Workbooks.Add(Template:=xlWBATWorksheet)
            With .Worksheets(1).Range("A1").Resize(UBound(v))
                .Value = v
                .EntireColumn.AutoFit
            End With
        End With

    End If

End Sub


Function GetFolder(Optional InitDir As String) As String
    Dim fldr        As Office.FileDialog
    Dim sItem       As String

    If Len(InitDir) = 0 Then
        sItem = CurDir
    Else
        sItem = InitDir
    End If

    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

    With fldr
        .Title = "Select a root folder to check"
        .AllowMultiSelect = False

        If Right(sItem, 1) <> "\" Then
            sItem = sItem & "\"
        End If

        .InitialFileName = sItem

        If .Show <> -1 Then
            sItem = vbNullString
        Else
            sItem = .SelectedItems(1)
        End If

    End With

    GetFolder = sItem
    Set fldr = Nothing
End Function


Sub ListFiles(ByVal sFolder As String, ByRef varrFiles As Variant, _
              Optional sFilter As String, Optional vSubFolders As Variant)

    Dim FSO         As Object
    Dim fsoFolder   As Object
    Dim fsoSubFolders As Object
    Dim fsoSubFolder As Object
    Dim fsoFile     As Object
    Dim i           As Long


    Set FSO = CreateObject("Scripting.FileSystemObject")

    If FSO.FolderExists(sFolder) Then
        Set fsoFolder = FSO.GetFolder(sFolder)
        Set fsoSubFolders = fsoFolder.SubFolders

        If fsoSubFolders.Count > 0 Then

            If IsMissing(vSubFolders) Then
                If MsgBox("Include subfolders?", _
                          vbQuestion + vbYesNo, _
                          "File list") = vbYes Then
                    vSubFolders = True
                Else
                    vSubFolders = False
                End If
            End If

        Else
            vSubFolders = False

        End If    'fsoSubFolders.Count > 0


        If Len(sFilter) = 0 Then sFilter = "*.*"


        For Each fsoFile In fsoFolder.Files

            If UCase(fsoFile.Name) Like UCase(sFilter) Then
                If IsEmpty(varrFiles) Then
                    ReDim varrFiles(1 To 1)
                End If

                i = UBound(varrFiles)

                If IsEmpty(varrFiles(i)) Then
                    i = i - 1
                End If

                i = i + 1

                ReDim Preserve varrFiles(1 To i)

                varrFiles(i) = fsoFile.Path

            End If    'UCase(fsoFile.Name) Like UCase(sFilter)

        Next fsoFile


        If vSubFolders Then
            For Each fsoSubFolder In fsoSubFolders
                Call ListFiles(fsoSubFolder.Path, varrFiles, sFilter, True)
            Next fsoSubFolder
        End If    'vSubFolders = True

    End If    'FSO.FolderExists(sFolder) = True

    Set fsoSubFolders = Nothing
    Set fsoFolder = Nothing
    Set FSO = Nothing

End Sub

Artik

THank you so much! this is perfect!