Sub Elapsed(): Dim T As Single
T = Timer
Colouring2
Application.StatusBar = (Timer - T)
End Sub
Sub Colouring2()
Dim Colour As Integer
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Colour = 5
Call Colouring(Colour)
Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cut Range("G2")
Range("F2:F" & Range("F" & Rows.Count).End(xlUp).Row).Cut Range("A2")
Colour = 10
Call Colouring(Colour)
'Determining % of non-black characters
Dim x As Integer, Black As Integer, y As Integer
x = 2
Do Until Cells(x, 2) = ""
Black = 0
For y = 1 To Len(Cells(x, 2))
If Cells(x, 2).Characters(y, 1).Font.ColorIndex = 1 Then
Black = Black + 1
Else
End If
Next y
Cells(x, 3).FormulaR1C1 = "=1-" & Black & "/LEN(RC[-1])"
x = x + 1
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
'MsgBox "Done"
End Sub
Sub Colouring(Colour As Integer)
Dim rw As Long, lr As Long
Dim k As Long, p As Long, vKEYs As Variant, vPHRASEs As Variant, vCOUNTs As Variant
ReDim vKEYs(0)
ReDim vPHRASEs(0)
With Worksheets("Subtitles") '<~~ set to the correct worksheet name\
'populate the vKEYs array
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
vKEYs(UBound(vKEYs)) = LCase(.Cells(rw, 1).Value2)
ReDim Preserve vKEYs(UBound(vKEYs) + 1)
Next rw
ReDim Preserve vKEYs(UBound(vKEYs) - 1)
'populate the vPHRASEs array
For rw = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
vPHRASEs(UBound(vPHRASEs)) = LCase(.Cells(rw, 2).Value2)
ReDim Preserve vPHRASEs(UBound(vPHRASEs) + 1)
Next rw
ReDim Preserve vPHRASEs(UBound(vPHRASEs) - 1)
ReDim vCOUNTs(0 To UBound(vPHRASEs))
'perform the counts
'For p = LBound(vPHRASEs) To UBound(vPHRASEs)
' For k = LBound(vKEYs) To UBound(vKEYs)
' vCOUNTs(p) = CInt(vCOUNTs(p)) + _
' (Len(vPHRASEs(p)) - Len(Replace(vPHRASEs(p), vKEYs(k), vbNullString))) / Len(vKEYs(k))
' Next k
'Next p
'return the counts to the worksheet
'.Cells(2, 3).Resize(UBound(vCOUNTs) + 1, 1) = Application.Transpose(vCOUNTs)
'run the helper procedure to Blue|Bold all of the found keywords within the phrases
Call key_in_phrase_helper(vKEYs, .Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)), Colour)
End With
End Sub
Sub key_in_phrase_helper(vKYs As Variant, rPHRSs As Range, Colour As Integer)
Dim p As Long, r As Long, v As Long
With rPHRSs
For r = 1 To rPHRSs.Rows.Count
'.Cells(r, 1) = .Cells(r, 1).Value2
'Range("E2") = Cells(r, 1)
'Range("E3") = Cells(r, 1).Value2
For v = LBound(vKYs) To UBound(vKYs)
p = 0
Do While CBool(InStr(p + 1, .Cells(r, 1).Value2, vKYs(v), vbTextCompare))
p = InStr(p + 1, .Cells(r, 1).Value2, vKYs(v), vbTextCompare)
'Debug.Print vKYs(v)
With .Cells(r, 1).Characters(Start:=p, Length:=Len(vKYs(v))).Font
'.Bold = True
.ColorIndex = Colour
End With
Loop
Next v
Next r
End With
End Sub
Bookmarks