Option Explicit
Sub ConvertColumnEToMonths()
Dim lngLastRow As Long
Dim lngLoopCtr As Long
Dim FilteredRange As Range
Dim rng As Range
Application.ScreenUpdating = False
Worksheets("Sheet1").Select
With Range("C1")
.EntireRow.Insert
End With
Range("E1") = "Months"
lngLastRow = Range("C" & Rows.Count).End(xlUp).Row
With Worksheets("Sheet1")
.AutoFilterMode = False
With Range("E1:E" & lngLastRow)
.AutoFilter Field:=1, Criteria1:="=*Years*", Operator:=xlOr, Criteria2:="=*yrs*"
End With
End With
With Worksheets("Sheet1").AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng Is Nothing Then
'Do nothing
Else
Set rng = ActiveSheet.AutoFilter.Range
rng.Offset(1, 2).Resize(rng.Rows.Count - 1).FormulaR1C1 = "=ExtractNumber(RC[-2])*12"
End If
With Worksheets("Sheet1")
.AutoFilterMode = False
With Range("E1:E" & lngLastRow)
.AutoFilter Field:=1, Criteria1:="=*Months*", Operator:=xlAnd
End With
End With
With Worksheets("Sheet1").AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng Is Nothing Then
'Do nothing
Else
Set rng = ActiveSheet.AutoFilter.Range
rng.Offset(1, 2).Resize(rng.Rows.Count - 1).FormulaR1C1 = "=ExtractNumber(RC[-2])"
End If
Worksheets("Sheet1").AutoFilterMode = False
With Columns("G:G")
.Copy
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
For lngLoopCtr = 1 To lngLastRow Step 1
If Cells(lngLoopCtr, "G") <> "" Then
Range("G" & lngLoopCtr).Copy Range("E" & lngLoopCtr)
End If
Next lngLoopCtr
Columns("G:G").Clear
Rows("1:1").Delete Shift:=xlUp
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Public Function ExtractNumber(rCell As Range, _
Optional Take_decimal As Boolean, Optional Take_negative As Boolean) As Double
'
' http://www.ozgrid.com/VBA/ExtractNum.htm
'
'
Dim iCount As Integer, i As Integer, iLoop As Integer
Dim sText As String, strNeg As String, strDec As String
Dim lNum As String
Dim vVal, vVal2
''''''''''''''''''''''''''''''''''''''''''
'Written by OzGrid Business Applications
'www.ozgrid.com
'Extracts a number from a cell containing text and numbers.
''''''''''''''''''''''''''''''''''''''''''
sText = rCell
If Take_decimal = True And Take_negative = True Then
strNeg = "-" 'Negative Sign MUST be before 1st number.
strDec = "."
ElseIf Take_decimal = True And Take_negative = False Then
strNeg = vbNullString
strDec = "."
ElseIf Take_decimal = False And Take_negative = True Then
strNeg = "-"
strDec = vbNullString
End If
iLoop = Len(sText)
For iCount = iLoop To 1 Step -1
vVal = Mid(sText, iCount, 1)
If IsNumeric(vVal) Or vVal = strNeg Or vVal = strDec Then
i = i + 1
lNum = Mid(sText, iCount, 1) & lNum
If IsNumeric(lNum) Then
If CDbl(lNum) < 0 Then Exit For
Else
lNum = Replace(lNum, Left(lNum, 1), "", , 1)
End If
End If
If i = 1 And lNum <> vbNullString Then lNum = CDbl(Mid(lNum, 1, 1))
Next iCount
ExtractNumber = CDbl(lNum)
End Function
