Free Microsoft Excel 2013 Quick Reference

Count number of characters in string text Results

Hi

If 'a' is a string that contains x number of characters, how do I find out what x is (in VBA)?

Many thanks
Johno

I know that the answer is probably simple, but I would like a formula that:

1. Counts the number of cells in a column with the same 18-character text string(Full String is 24) using a RIGHT( function.

2. Returns a 1 if there is 1 and a zero if the count is greater than 1.

Thanks,
Thomas

Count Words in a Range of Excel Worksheet Cells

Unlike Microsoft Word, Excel does not give us a ready made way to find out the number of words in a cell, or a range of cells containing text, or words. However, with the help of the SUBSTITUTE function/formula and the LEN function/formula we can. If you are not familiar with these functions/formulas I have written an explanation below.

SUBSTITUTE

Syntax
=substitute(text,old_text,new_text,instance_num)

What it does
Substitutes new_text for old_text in a text string. Use SUBSTITUTE when you want to replace specific text in a text string; use REPLACE when you want to replace any text that occurs in a specific location in a text string.

Example
=SUBSTITUTE(A1, "Sales", "Cost") If A1 had the text "Sales Data" the formula result would be "Cost Data".

LEN

Syntax
=len(text)

What it does
LEN returns the number of characters in a text string.

Example
=LEN(A1) If A1 had the text "Sales Data" the formula result would be 10 as A1 has 9 text characters and 1 space character.

Count Words in a Cell

The formula below will return the number of words (not characters) in cell A1

=LEN(A1)-LEN(SUBSTITUTE(A1," ",""))+1

Be aware that superfluous spaces are also counted and may give misleading results. To ensure accuracy we can simply nest the TRIM formula function/formula in the first LEN

=LEN(TRIM(A1))-LEN(SUBSTITUTE(A1," ",""))+1

Count Words in a Range of Cells

The formula below will return the number of words (not characters) in cells A1:A5

=LEN(TRIM(A1&A2&A3&A4&A5))-LEN(SUBSTITUTE(A1&A2&A3&A4&A5," ",""))+5

Or

=LEN(TRIM(A1&A2&A3&A4&A5))-LEN(SUBSTITUTE(A1&A2&A3&A4&A5," ",""))+Rows(A1:A5)

Keep in kind that the formula above WILL return 1 for an empty cell, due to +1. Overcome that problem by use of this function;

=LEN(TRIM(A1))-LEN(SUBSTITUTE(TRIM(A3)," ",""))+(LEN(A1)>1)

The +(LEN(A1)>1) will either return TRUE (1) or FALSE (0).

Did a search on the forum but didn't find a similar thread. I have a very large spreadsheet and want to count the number of times a particular text string shows up in a column. I can't use autofilter due to the 1000 limit.

Here's an example, Column C contains:
Dan Parker
John Doe
Dan Smith
Jill Smith

So if I search on *Dan*, the function should return a count of 2.

I've used COUNTIF before to return values when the whole cell = a certain value but in my case the cell may have 200 characters and I want to count based on a fuzzy search. I would like to do this in a function and not a macro. Any help would be appreciated.

I need to count the number of Carriage returns in a string of text in a group of merged cells also I need to add a carriage return after the 1024 character because I have the wrap text on. My overall goal is have copy text fit into a group of merged cells without any being cut off by excel.

Hi
Probably quite simple. Can someone help me with a simple formula that returns a numerical value to identify the count of the number of characters in a cell. For example, CAT would return a 3, HORSE would return a 5...and so on.
thanks
S

Does anyone know a way to automatically count how many times a certain
character counts in a text string?

Experts:
I have the following formula in a cell:
=IF(C23="","",IF(C92<Wt2,(('gen. data'!$D$85*'up plen (B)'!C486^3+'gen. data'!$D$86*'up plen (B)'!C486^2+'gen. data'!$D$87*'up plen (B)'!C486+'gen. data'!$D$88)*(Wt2-C92)/(Wt2-Wt1)+('gen. data'!$D$90*'up plen (B)'!C486^3+'gen. data'!$D$91*'up plen (B)'!C486^2+'gen. data'!$D$92*'up plen (B)'!C486+'gen. data'!$D$93)*(C92-Wt1)/(Wt2-Wt1)), (('gen. data'!$D$90*'up plen (B)'!C486^3+'gen. data'!$D$91*'up plen (B)'!C486^2+'gen. data'!$D$92*'up plen (B)'!C486+'gen. data'!$D$93)*(Wt3-C92)/(Wt3-Wt2)+('gen. data'!$D$95*'up plen (B)'!C486^3+'gen. data'!$D$96*'up plen (B)'!C486^2+'gen. data'!$D$97*'up plen (B)'!C486+'gen. data'!$D$98)*(C92-Wt2)/(Wt3-Wt2))))

As you can see, this formula is long, and it calls user-defined functions within it. To be more precise, this formula is over 400 characters long. Here's the problem:
When I run the following Sub, it returns 231. There are obviously more than 231 characters in this string, so why is it not counting each one, and how do I make it so it counts each character in the text and returns the total number of characters in the formula?

Sub celllengthtest()
Dim l As Long

ActiveCell.Select
l = Len(Selection.Text)
Selection = l

End Sub
Thanks for your help

Hi.

I'm trying to write some code that merges the correct number of cell rows so that a cell of fixed width can contain a long string of text.
The challenge is to merge the correct number of rows, so that when the text string is wrapped in the cell it is neither cut off (because too few rows have been merged), nor does it leave any empty rows at the end of the base of the merged cell (because too many rows have been merged.)

I have tried estimating the number of characters that will fit across the width of the cell and then dividing the length of the text string (in characters) to calculate how many rows will be required to contain the whole string.
But because I need to use Arial as the font for this (and not some font with fixed width characters, like Courier for example), counting the characters in the string does not give an accurate measure of how many rows are required to fit all the text.
Also, because wrapping the text splits the string at unpredicatable points along its length (at the location of spaces, or hyphens - and I want it to do this), this adds to the difficulty of knowing how many rows will be required to fit all the text in the merged cell.

What I find is that because my estimation of the number of characters that fit across the cell is only approximate, either the end of the text is cut off or there are too many rows (so there is a space at the bottom of the cell.)

Is there another way to go about this?

I have considered creating a list of the widths of each of the characters in the Arial font, so that I can make a more accurate estimate of the width of the character string, but this won't help with the unpredicatable break-points that arise when you wrap text.

Is there an easier way of going about this?

Any help you could give me with this issue would be greatly appreciated.

Thanks.

Hi all,

I got a question when I was doing a very simple macro program.
I got three Strings as follows:

String1 = "ABC"
String2 = "你們好"
String3= "にっぽん"

Dim daysLengthString As String
Dim daysLength As Variant

daysLengthString = String1
daysLength = Len(daysLengthString)

MsgBox "The text " & daysLengthString1 & " is " & (daysLength) & " characters long"
MsgBox "The text " & daysLengthString2 & " is " & (daysLength) & " characters long"
MsgBox "The text " & daysLengthString3 & " is " & (daysLength) & " characters long"

Please give me some suggestion how to improve the program.

Thank you

Kitty.

Hi All
I am currently trying to make an Excel VBA which will extract a table from a PDF File. I got to the point where, if I manually cut and paste the table into a .txt file I can extract it and remake the table.
However I want to be able to access pdf directly from the VBA function. When ever I try this, the words and numbers come out as random characters. I am guessing it is probably compatibility or that I need to access the pdf through another reader.
either way any help would be great, my code I have right now is pasted below for opening the file and separating each word in the file into separate cells.


	VB:
	
 file() 
     
    Dim Filename As String 
    On Error Resume Next 
    Filename = Cells(11, 3) 
    Open Filename For Input As #1 
    If Err  0 Then 
        MsgBox "Not found: " & Filename, vbCritical, "File Location Error" 
        Exit Function 
    End If 
     
    Dim tmpString As String 
    Dim aRow As String 
    Dim X As Integer 
    Dim Y As Integer 
    Dim JSI As String 
    Dim Length As String 
    Dim bRow As Integer 
     
    bRow = 1 
    aRow = 1 
     
    Do Until EOF(1) 
         'Read a line of text
        Line Input #1, tmpString 
         
        Dim newString As String 
         'count # of words in string
        Dim positionIndex As Integer 
        Dim numberOfWords As Integer 
        positionIndex = 1 
         
        For positionIndex = 1 To Len(tmpString) 
            If Mid(tmpString, positionIndex, 1) = Chr(32) Then 
                numberOfWords = numberOfWords + 1 
            End If 
        Next positionIndex 
         
        Dim nextWord As String 
        Dim wordIndex As Integer 
        For wordIndex = 1 To numberOfWords 
            nextWord = ExtractElement(tmpString, wordIndex, Chr(32)) 
            Cells(bRow, wordIndex).Value = nextWord 
        Next wordIndex 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hello,

While further refining my waterfall VBA code, I could not find the way to position the data labels on top of the stacks. And of course, the labels are often positioned in the stacks themselves, making it difficult to read and very ugly to watch.

Is there a way to request the labels to be on top of the stacks?

Here comes my code, in which data labels are displayed only if they are different from zero. I also attach a file ready to be tested.

Help on this would, as usual, be MUCH appreciated

Thank you in advance


	VB:
	
 DrawWaterfallChart() 
     
    Dim SheetName As String 
    Dim Data1Col As Integer, Data2Col As Integer, LabelsCol As Integer 
    Dim FirstRow As Long, LastRow As Long 
     
    LabelsCol = 1 
    Data1Col = 2 
    Data2Col = 3 
    FirstRow = 3 
    LastRow = 23 
     
    SheetName = "Global" 
     
     
    Dim rng1 As Range, rng2 As Range, rnglabels As Range, rngGlobal As Range 
     
    Dim myChtObj As ChartObject 
    Dim iColumn As Long 
     
    Dim plus() As Double 
    Dim minus() As Double 
    Dim basement() As Double 
    Dim labels() As String 
    Dim Height As Long 
    Height = LastRow - FirstRow + 1 
    Dim Initial As Double 
     
     'Let's put the data in arrays because in the final application the data will be coming from arrays
     
    Redim plus(1 To Height) 
    Redim minus(1 To Height) 
    Redim basement(1 To Height) 
    Redim labels(1 To Height) 
     
    Dim Row As Long, Col As Integer 
     
    For Row = 1 To Height 
        If Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) > Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col) Then

            plus(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) - Sheets(SheetName).Cells(FirstRow + Row - 1,
Data1Col) 
            minus(Row) = 0 
        Else 
            plus(Row) = 0 
            minus(Row) = -Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) + Sheets(SheetName).Cells(FirstRow + Row - 1,
Data1Col) 
        End If 
    Next Row 
     
    For Row = 1 To UBound(plus) 
        If plus(Row) > 0 Then 
            basement(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) 
        Else 
            basement(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col) 
        End If 
        labels(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, LabelsCol) 
    Next Row 
     
    Set myChtObj = Sheets(SheetName).ChartObjects.Add(Left:=250, Width:=375, Top:=75, Height:=225) 
     
    Dim Invisible As Series 
     
    Dim Positive As Series 
     
    Dim Negative As Series 
     
     ' Add the chart
    With myChtObj.Chart 
        .ChartArea.Fill.Visible = False 
        .PlotArea.Format.Fill.Solid 
        .PlotArea.Format.Fill.Transparency = 1 
        .HasTitle = True 
        .HasLegend = False 
         
        .ChartTitle.Text = "My chart" 
         
        .Axes(xlCategory, xlPrimary).HasTitle = True 
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Units" 
        .Axes(xlValue, xlPrimary).HasTitle = True 
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Quantity" 
         
         
        .ChartGroups(1).GapWidth = 0 
         
         ' Make Column Stacked chart
        .ChartType = xlColumnStacked 
         
         ' Add series from selected range, column by column
        Set Invisible = .SeriesCollection.NewSeries 
        With Invisible 
            .Values = basement 
            .XValues = labels 
            .Name = "Labels" 
            With .Border 
                .ColorIndex = 13 
                .Weight = xlMedium 
                .LineStyle = xlNone 
            End With 
            .Format.Fill.Visible = False 
            .Format.Line.Transparency = 0 
            .MarkerStyle = xlNone 
        End With 
         
        Set Positive = .SeriesCollection.NewSeries 
        With Positive 
            .Values = plus 
            .XValues = labels 
            .Name = "Plus" 
            .Interior.ColorIndex = 14 
             
            .HasDataLabels = False 
        End With 
         
        nPts = Positive.Points.Count 'save the number of points
        aVals = Positive.Values 'save all the values in array
         
        For Col = 1 To nPts ' loop through all points
            If aVals(Col) > 0 Then 
                t = "+" & CStr(Round(aVals(Col))) 
                Positive.Points(Col).HasDataLabel = True 
                With Positive.Points(Col).DataLabel 
                    .Text = t 
                     ' Here I'd like to be able to request the data label to be above the stack (xlLabelPositionAbove)
                    .Position = 4 'Only accepts 3 (xlLabelPositionInsideEnd) and 4 (xlLabelPositionInsideBase)
                    With .Font 
                        .ColorIndex = 14 
                        .Size = 6 
                    End With 
                End With 
            End If 
        Next Col 
         
         
        Set Negative = .SeriesCollection.NewSeries 
        With Negative 
            .Values = minus 
            .XValues = labels 
            .Name = "Minus" 
            .Interior.ColorIndex = 18 
        End With 
         
        nPts = Negative.Points.Count 'save the number of points
        aVals = Negative.Values 'save all the values in array
         
        For Col = 1 To nPts ' loop through all points
            If aVals(Col) > 0 Then 
                t = "-" & CStr(Round(aVals(Col))) 
                Negative.Points(Col).HasDataLabel = True 
                With Negative.Points(Col).DataLabel 
                    .Text = t 
                     ' Here I'd like to be able to request the data label to be above the stack (xlLabelPositionAbove)
                    .Position = 4 'Only accepts 3 (xlLabelPositionInsideEnd) and 4 (xlLabelPositionInsideBase)
                    With .Font 
                        .ColorIndex = 18 
                        .Size = 6 
                    End With 
                End With 
            End If 
        Next Col 
         
    End With 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I have a relatively simple problem which I fear has all too easy an answer, but I appreciate anyone's input/help with this problem.

I am trying to use count, countif, or any other function I can think of to try and solve this problem but I have thus far been unsuccessful in doing so. I also did not see an example of this on your previous threads/postings (I think I checked them all ).

I have several columns of data with numerical data either 3, 4, or 5 characters in length. In many separate places I need to be able to check if a particular character position has a particular number/character in it. Then I wish to count the number of such occurrences.

For example:
A1 = 123
A2 = 12345
A3 = 4321
A4 = 2321
A5 = 4232

Have tried dozens of variations similar to...
B5 = =COUNTIF(A1:A5,"?2??")...I think/intend this to yield (3)...but it yields (0)

I have also tried several variations using '*' rather than '?' where it can be substituted.

It seems if the cell contains text string rather than a series of numbers. This example works just fine:
(if: A1:A5 were asd, addr, admin, ardv, and, B5 = =COUNTIF(A1:A5,"??d?"))
I get the correct count (4), but when numerical values are in the cells the formula does not work.

Is there something specific about numbers that is not covered when you use "" to specify a text string...if so how do I change the numbers in the column to a text string (and formatting the cells to be 'text' by right clicking does not seem to help).

Or more likely I am missing some nuance of excel.

Help, Thank You!

1. The functions SEARCH(), SEARCHB(), FIND() and FINDB() return a #value
error if they didn't find the "find_text" string within the "within_text"
string. This forces the user to use long formulas such as
=IF(ISERROR(SEARCH(A1, A2)), 0, SEARCH(A1, A2)) in order to avoid errors.
Since in case of success, these functions return the serial number of the
first matching character, starting from 1, I suggest that these functions
return either 0 or -1 if they can't find that text.
2. I suggest to add functions that count the number of times that one text
exists within another, for example:
FINDNUM(find_text, within_text), SEARCHNUM(find_text, within_text)
FINDNUM is case-sensitive, SEARCHNUM is not.
Find_text is the text you want to find.
Within_text is the text containing the text you want to find.
Example: FINDNUM("ma", "Mamma mia!") returns 1, SEARCHNUM("ma", "Mamma
mia!") returns 2.

----------------
This post is a suggestion for Microsoft, and Microsoft responds to the
suggestions with the most votes. To vote for this suggestion, click the "I
Agree" button in the message pane. If you do not see the button, follow this
link to open the suggestion in the Microsoft Web-based Newsreader and then
click "I Agree" in the message pane.

http://www.microsoft.com/office/comm...lic.excel.misc

Within a cell, I need to count the number of times a given character (dash)
occurs. I suspect that I need to use a recursive FIND, but I don't know how
to do it. Can anyone help?
Thanks,
Bob

I have a range, 11 wide by 47 tall. For discussion, we'll say it is 10 by 50.
I have strings of text within these cells, which may or may not include a
small string of text in the middle of the strings, such as "(LA)" within the
string "CA 101 - Introduction to Computers (LA) (CA 99, FND 101)" .
Each cell will be different, but many will have "(LA)" or other 4 or 5
character strings within the larger strings, like the one above.
I need a formula (hopefully in one cell) to count the number of times or
cells such a string "(LA)" appears within the larger strings in the cells in
this range.

Thanks in advance for giving your time to this dilemma.

I'm in need of some help here, and also with a macro question, too.
I need to replace text

From To
A1 A01
The series goes from A1-A32, B1-B32, ...R32 that are on many sheets

I have no problem changing the text, but can't seem to get the .FindNext to
work.
I get Compile error: Invalid or unqualified reference
on line
Set Myfound = .FindNext(Myfound)

Here is my macro (minus some code to shorten the message)
Can someone Please Help Me! Thanks in advance

Sub replaceinworkbook()
'
' replaceinworkbook Macro
' Macro recorded 10/8/2003 by rcochran
'
Dim strPin As String 'holds string to search i.e.
A1,A2...A9,B1,B2...B9,...R9
Dim n As Integer ' variable for ASCII characters Chr(n)
Dim m As Integer ' variable for incrementing 1 to 9
Dim Myfound As Range ' cell containing the text you want to search
Dim cell As String 'variable to hold found cell text
Dim firstAddress As String 'variable to keep a reference to the first
address of the Myfound
Dim n_len As Integer 'variable to count number of text characters in
Myfound
Dim m_instr As Integer 'variable count where strPin is located in Myfound

For n = 65 To 82
For m = 1 To 9
strPin = Chr(n) & m 'initialize variable to A1. Chr(65) is A, so
Chr(65) & 1 is A1

' set Myfound to the cells that are found during search
Set Myfound = Cells.Find(What:=strPin, after:=ActiveCell,
LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=False)

If Myfound Is Nothing Then 'if strPin is not found leave If

GoTo exit_if 'jump out of If

Else

Myfound.Activate 'if strPin is found, then activate cell
firstAddress = Myfound.address

Do

cell = ActiveCell.FormulaR1C1 'set cell to Myfound
n_len = Len(cell) ' return number of characters in
cell

code removed from this message

Set Myfound = .FindNext(Myfound)
Loop While Not Myfound Is Nothing And Myfound.address
firstAddress

end if

exit_if:

Next m
Next n

End Sub

I have a text string count of 1050 (This is a variable)including spaces in Cell A1.

I need to spread this over 4 Cells with varying string counts.

Cell B1 String count including spaces 299
Cell B2 String count including spaces 301
Cell B3 String count including spaces 275
Cell B4 String remaining text including spaces (Variable)

Thanks in anticipation.

Hi all,

I've hit a snag and cannot figure out a workaround.
I am trying to search row by row for any number starting with 425 (the numbers will range from 4250 to 4259) and report a binary result.

say the data looked like this:
A B C D (the columns go out to IC,the rows to 24875!!)
Row1: 0385 / Jack / 4259 / Phil

i have been trying =if(countif(a1:e1),"425?"),1,0), however, it doesnt seem to recognize the wildcard. I have tried using numbers as text and numbers and i get the same result. since the dataset is so large, im trying to automate whatever i can without having to use a nested if(or( to find all the data semi-automatically. any thoughts?
thanks,
pete

I need to return the "Subject" of any type of file (.txt, .pdf, .docx, etc.). The subject property does not need to be changed, only read. I got it to work for Excel files with tags, but it doesn't return subjects of PDFs. Maybe an "IF" "THEN" statement or "CASE" for different doc types? I have no clue.

FIRST TRIAL
Sub ReturnSubjectOfFiles()
Dim objShell As Object, objFolder As Object
Dim iCounter As Long, iRow As Long, iCol As Integer
Dim strFileName As Variant
Dim sDir
sDir = Cells(1, 1).Value

Application.ScreenUpdating = False
Range("A:C").ClearContents
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(sDir)
iRow = 3
iCol = 1
For Each strFileName In objFolder.Items
iCounter = 22
Cells(iRow, 3).Value = objFolder.GetDetailsOf(strFileName, iCounter)
Cells(iRow, 2).Value = objFolder.GetDetailsOf(strFileName, 0)
iRow = iRow + 1
Next strFileName
Application.ScreenUpdating = True
End Sub

SECOND TRIAL: More extensive, includes subfolders as well (LOVE THIS)- $5 kicker if you can incorporate this as well. (This is within a form I created)

Private Sub cmdRunReport_Click()
'
' Requires Private Sub below!
'Unprotect Sheet while macros run
Dim sh As Worksheet
Dim myPassword As String
myPassword = "2012"
For Each sh In ActiveWorkbook.Worksheets
sh.Unprotect Password:=myPassword
Next sh

If Cells(2, 2) "" Then
Columns("B:G").Select
Selection.Delete Shift:=xlToLeft
End If
Worksheets("Sheet1").Range("A2") = TextBox2
Worksheets("Sheet1").Range("A3") = TextBox3
'Sets folder as variable; user inputs folder name into text box txtFldrName (Risk/Mitigation)
Dim FolderName As String
FolderName = txtFldrName
Dim FileName As Variant
Dim FileCollection As New Collection ' create a collection of filenames
'Filling a collection of filenames (search for files in FolderName and include files located within subdirectories)
Call FileSearch(FileCollection, FolderName, "*.*", True)
'Print file name list to column B, print date of last review to column E
For Each FileName In FileCollection ' cycle for list(collection) processing
Dim iRow As Integer
Dim iCol As Integer
iCol = 2 'Place file names in column B
iColDate = 5 'Place keyword/date of last review into column E
iRow = 2 'Place first file name into the second row

Do While Cells(iRow, iCol).Value ""
iRow = iRow + 1
Loop

Cells(iRow, iCol).Value = FileName
Cells(iRow, iColDate).Value = FileDateTime(FileName) '(Risk/Mitigation)-change to keyword
Next FileName
'Return number of rows of data
Dim NumEntries As Integer, myRange As Range
Set myRange = Columns("B:B")
NumEntries = Application.WorksheetFunction.CountA(myRange)
' Print to immediate debug window and message if no file was found
'(Risk/Mitigation)-Add instructions on how to find correct file
If FileCollection.Count = 0 Then
Debug.Print "No file was found !"
MsgBox "No file was found !"
End If
'Convert full file path name to file name (i.e. cut off folder name string)
Range("D1").Select
ActiveCell.FormulaR1C1 = "=IF(R1C1"""",LEN(RC[-3]))"
Range("D2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]"""",LEN(RC[-2]))"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]"""",RIGHT(RC[-1],RC[1]-(R1C4+1)),"""")"

'Fill equations down to row 10,000
'(Risk/Mitigation)
'Cut all new data; re-paste as values without equations (saves space)
Range("C2:D2").Select
Selection.AutoFill Destination:=Range("C2:D10000"), Type:=xlFillDefault

'Remove equation dependencies
Columns("C:C").Select
Selection.Copy
Columns("C:C").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'Get number of days since last review
Columns("D:D").Select
Selection.ClearContents 'previously, data was used to truncate file name
Range("D2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]"""",ROUNDUP(R14C1-RC[1],0),"""")"

'Assign status to number of days since last review
'(Risk/mitigation) Will this change? Management requirements- consider adding password protection to cells A2 and A3
Range("F2").Select
'While cell value in Column B is not empty, enter "Red" if D2>$A$15, enter "Yellow" if D2>$A$16, and "Green" for all others
ActiveCell.FormulaR1C1 = _
"=IF(RC[-4]"""",IF(RC[-2]>R15C1,""Red"",IF(RC[-2]>R16C1,""Yellow"",""Green"")),"""")"

' Add Headers to Rows
Range("B1").Select
ActiveCell.FormulaR1C1 = "Full File Name"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Abbreviated File Name"
Range("D1").Select
ActiveCell.FormulaR1C1 = "# Days Since Last Review"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Last Edit"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Status"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D10000"), Type:=xlFillDefault
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F10000"), Type:=xlFillDefault
'(Risk/Mitigation) too many files in folder to create list
'Remainder of macro is for FORMATTING ONLY
Range("D1").Select
With ActiveCell.Characters(Start:=1, Length:=24).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("E1").Select
With ActiveCell.Characters(Start:=1, Length:=9).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("F1").Select
ActiveCell.FormulaR1C1 = "Status"
Columns("B:F").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
Range("B1:F1").Select
Selection.Style = "40% - Accent1"
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Columns("F:F").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Green"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16752384
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13561798
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Columns("F:F").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Yellow"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16751204
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 10284031
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Columns("F:F").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""Red"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("B1:F1").Select
Columns("C:C").ColumnWidth = 53.14
Columns("E:E").EntireColumn.AutoFit
Columns("E:E").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("E:E").EntireColumn.AutoFit
Range("B1:F1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("C1").Select
Columns("B:B").ColumnWidth = 10.29
Columns("D:D").ColumnWidth = 11.14
Rows("1:1").EntireRow.AutoFit

Columns("C:F").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With

Worksheets("Sheet1").Range("A1") = txtFldrName
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-1]"""",RIGHT(RC[-1],(LEN(RC[-1])-LEN(R1C1))-1),"""")"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C10000"), Type:=xlFillDefault
For Each sh In ActiveWorkbook.Worksheets
sh.Protect Password:=myPassword
Next sh
End Sub

Private Sub FileSearch(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
'
' Search files in Path and create FoundFiles list(collection) of file names(path included) accordant with Mask (search in subdirectories if enabled)

Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection
'(Risk/Mitigation)Add backslash at the end of path if not present
pPath = Trim(pPath)
If Right(pPath, 1) "" Then pPath = pPath & ""
' Searching files accordant with mask
DirFile = Dir(pPath & pMask)
Do While DirFile ""
pFoundFiles.Add pPath & DirFile 'add file name to list(collection)
DirFile = Dir ' next file
Loop
' Procedure exiting if searching in subdirectories isn't enabled
If Not pIncludeSubdirectories Then Exit Sub
' Searching for subdirectories in path
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile ""
' Add subdirectory to local list(collection) of subdirectories in path
If DirFile "." And DirFile ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
DirFile = Dir 'next file
Loop
' Subdirectories list(collection) processing
For Each CollectionItem In SubDirCollection
Call FileSearch(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories) ' Recursive procedure cal
Next

frmNameStatusRept.Hide
End Sub

Private Sub CommandButton1_Click()
frmFolderPathHelp.Show
End Sub

Private Sub CommandButton2_Click()
Sub ClearFields()
'
' ClearFields Macro
'
Columns("B:G").Select
Selection.Delete Shift:=xlToLeft
'
End Sub
Private Sub Frame2_Click()
End Sub