[Solved] Review data in excel

[Mythbuster]

I have a lot of spreadsheets in various folders that was reviewed and partial text inside each cell of every excel where there was a change, I made the color red, striked off and created a new text within each cell and some entire cells.
I want to create for each folder when I run the vba, tabs that are created with file names shortened to 15 chars, and that contains a report of cell references that has either partial text in cell eg. C21 has some partial text red or stikeoff or both should be listed with (Strikeout, Red or both ) reason as the column, likewise the next find of font in red or stikeout in next row ..this for whole directory.
If there is no font in red or strikeout no tab to be created.
I see these links from your https://www.exceldemy.com/excel-if-font-color-is-red-then/ from Sanjida but I wasn't sure how to adapt it from each partial text as well
We may use in look Mid() and for each char and test if the that font it red or strikeout ? Please can you help ?

 

[Seemanto Saha]

Hello Mythbuster,

Thanks for sharing your problem with us. I understand that you want to create a review report. According to your specification, the workbook that contains the review report should have sheets named after the reviewed workbooks that contain any cells with complete or partial red font or strikethrough text.

To resolve your problem, I created 4 Workbooks (download from attachment) that contain one or multiple worksheets. The workbooks are located in 3 different folders.​

​

Except for the “Fourth Reviewed Spreadsheet” workbook, every workbook contains one or multiple cells with complete or partial red font or strikethrough text or both.​

Afterward, I have taken an xlsm file and entered the code from the next reply (as we can't reply with more than 10,000 characters) in a module. (Press Alt + F11 to open the Visual Basic Editor window and from the Insert tab, select the Module option to insert a module).​

Click on the Save button and Run the generateReviewReport Subroutine.

3 worksheets will be added to the workbook where you want to generate the review reports. As the “Fourth Reviewed Spreadsheet” didn’t contain any cells with complete or partial red font or strikethrough texts, no worksheet is added for this one.
​

The workbook with the review report is also attached below. Make necessary adjustments according to the number of reviewed workbooks you have, their file paths, and the report format. Share your feedback with us.​

Regards,
Seemanto Saha
ExcelDemy

 

[Seemanto Saha]

VBA Code:

Sub generateReviewReport()
    
    'declare your required number of file path variables
    Dim file_path1, file_path2, file_path3, file_path4 As String
    Dim file_pathArr() As Variant
    
    'Assign file paths to the declared variables
    file_path1 = "F:\Exceldemy\FQ-182\Folder 1\First Reviewed Spreadsheet.xlsx"
    file_path2 = "F:\Exceldemy\FQ-182\Folder 1\Second Reviewed Excel File.xlsx"
    file_path3 = "F:\Exceldemy\FQ-182\Folder 2\Third Reviewed Excel File.xlsx"
    file_path4 = "F:\Exceldemy\FQ-182\Folder 3\Fourth Reviewed Spreadsheet.xlsx"
    
    'update the array with all file path variables
    file_pathArr = Array(file_path1, file_path2, file_path3, file_path4)
    
    Dim lb, ub As Integer
    lb = LBound(file_pathArr)
    ub = UBound(file_pathArr)
    
    Dim i As Integer
    Dim file_nameArr() As Variant
    ReDim file_nameArr(lb To ub)
    Dim start_loc, end_loc As Integer
    
    For i = LBound(file_pathArr) To UBound(file_pathArr)
        start_loc = InStrRev(file_pathArr(i), Application.PathSeparator)
        end_loc = InStr(file_pathArr(i), ".")
        file_nameArr(i) = Mid(file_pathArr(i), start_loc + 1, end_loc - start_loc - 1)
    Next i
    
    Dim wb_name As String
    Dim msg As String
    Dim lastRow, lastCol As Integer
    Dim j, k As Integer
    Dim font_color As String
    Dim font_strike As Boolean
    Dim cell_value As String
    Dim count_red, count_strike As Integer

    For i = lb To ub
        Set wb = Workbooks.Open(file_pathArr(i))
        
        If Len(file_nameArr(i)) <= 15 Then
            wb_name = file_nameArr(i)
        Else
            wb_name = Left(file_nameArr(i), 15)
        End If
        
        For Each sh In wb.Sheets
            lastRow = sh.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            lastCol = sh.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            Set rng = sh.Range(sh.Cells(1, 1), sh.Cells(lastRow, lastCol))
            
            For Each cell In rng
                count_red = 0
                count_strike = 0
                font_color = "not red"
                font_strike = False
                cell_value = cell.Text
                
                For j = 1 To Len(cell_value)
                    If cell.Characters(j, 1).Font.Color = RGB(255, 0, 0) Then
                        font_color = "red"
                        count_red = count_red + 1
                    Else
                        font_color = "not red"
                    End If
                    
                    If cell.Characters(j, 1).Font.Strikethrough = True Then
                        font_strike = True
                        count_strike = count_strike + 1
                    Else
                        font_strike = False
                    End If
                    
                Next j
                
                If font_color = "red" And count_red = Len(cell_value) Then
                    If font_strike = True And count_strike = Len(cell_value) Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Complete Red and Strikethrough"
                        updateReport wb_name, msg
                    End If
                    
                    If font_strike = True And count_strike <> Len(cell_value) Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Complete Red and Partial Strikethrough"
                        updateReport wb_name, msg
                    End If

                    If font_strike = False And count_strike > 0 Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Complete Red and Partial Strikethrough"
                        updateReport wb_name, msg
                    End If
                    
                    If font_strike = False And count_strike = 0 Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Complete Red"
                        updateReport wb_name, msg
                    End If
                End If
                
                If font_color = "red" And count_red <> Len(cell_value) Then
                    If font_strike = True And count_strike = Len(cell_value) Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Red and Complete Strikethrough"
                        updateReport wb_name, msg
                    End If
                    
                    If font_strike = True And count_strike <> Len(cell_value) Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Red and Strikethrough"
                        updateReport wb_name, msg
                    End If

                    If font_strike = False And count_strike > 0 Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Red and Strikethrough"
                        updateReport wb_name, msg
                    End If
                    
                    If font_strike = False And count_strike = 0 Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Red"
                        updateReport wb_name, msg
                    End If
                End If
                
                If font_color = "not red" And count_red > 0 Then
                    If font_strike = True And count_strike = Len(cell_value) Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Red and Complete Strikethrough"
                        updateReport wb_name, msg
                    End If
                    
                    If font_strike = True And count_strike <> Len(cell_value) Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Red and Strikethrough"
                        updateReport wb_name, msg
                    End If

                    If font_strike = False And count_strike > 0 Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Red and Strikethrough"
                        updateReport wb_name, msg
                    End If
                    
                    If font_strike = False And count_strike = 0 Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Red"
                        updateReport wb_name, msg
                    End If
                End If
                
                If font_color = "not red" And count_red = 0 Then
                    If font_strike = True And count_strike = Len(cell_value) Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Complete Strikethrough"
                        updateReport wb_name, msg
                    End If
                    
                    If font_strike = True And count_strike <> Len(cell_value) Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Strikethrough"
                        updateReport wb_name, msg
                    End If

                    If font_strike = False And count_strike > 0 Then
                        msg = "Sheet: " & sh.Name & ", Cell: " & Join(Split(cell.Address, "$"), "") & ", Partial Strikethrough"
                        updateReport wb_name, msg
                    End If
                End If
                
            Next cell
            
        Next sh
        
        wb.Close
        
    Next i
    
End Sub

Sub updateReport(sh_name As String, msg As String)

    Set active_wb = ThisWorkbook
    Dim check_sheet As Boolean
    check_sheet = False
    Dim i As Integer
    
    For i = 1 To active_wb.Sheets.count
        If active_wb.Sheets(i).Name = sh_name Then
            check_sheet = True
            Exit For
        End If
    Next i
    
    Dim lastRow As Integer
    
    If check_sheet = False Then
        active_wb.Sheets.Add.Name = sh_name
        Set ws = active_wb.Sheets(sh_name)
        ws.Cells(1, 1).Value = msg
    End If
    
    If check_sheet = True Then
        Set ews = active_wb.Sheets(sh_name)
        lastRow = ews.Cells(Rows.count, 1).End(xlUp).Row
        ews.Cells(lastRow + 1, 1).Value = msg
    End If
    
    active_wb.Sheets(sh_name).Cells(1, 1).EntireColumn.AutoFit
    
End Sub