Data Normalisation

Option Explicit
     Dim strText As String
     Dim preString As String
     Dim postString As String
     Dim uCount As String
     Dim lCount As String
     Dim B As Integer
     Dim i As Integer
     Dim char2 As String

Sub Main() ' Click to run script. Script Standardises Text in a column. I.e. USA Armed Forces becomes USA Armed Forces, BarRy JONES becomes Barry Jones
     Dim strText As String
     Dim cRow As Integer 'Current row
     cRow = 2
     Sheets("Main").Select 'Select the Sheet
     Range("A2").Select

     Do While ActiveCell > ""
         strText = ActiveCell
         strText = fProper(strText)
         Cells(cRow, 2) = strText
         cRow = cRow + 1
         Cells(cRow, 1).Select
     Loop
 
End Sub


Function fProper(strTxt As String)
     strText = strTxt
     uCount = 0
     lCount = 0
 
     'Seek the first space.
     B = InStr(1, strText, " ")
 
     'Test if there IS a space
     If B > 0 Then
         preString = Left(strText, B - 1)
         postString = Mid(strText, B, (Len(strText) - B) + 1)
 
         'Cycle through the post-string;
         'at least 1 lower case character will imply that the caps lock wasn't on
         For i = 1 To Len(postString)
             Select Case Asc(Mid(postString, i, 1))
                 Case 65 To 90
                     uCount = uCount + 1
                 Case 97 To 122
                     lCount = lCount + 1
                 Case Else
            End Select
            If lCount > 0 Then Exit For 'Go no further if a lowercase character is found
        Next i
 
        If lCount > 0 Then
            postString = StrConv(postString, 3) '3=proper case, 2=lowercase, 1=upper case
 
            'If the 2nd character of the pre-string is uppercase, it is reasonable
            'to assume the entire pre-string should be too.
            char2 = Mid(preString, 2, 1)
            If Asc(char2) >= 65 And Asc(char2) <= 90 Then
                preString = StrConv(preString, 1) 'entire pre-string is upper
            Else
                preString = StrConv(preString, 3) 'pre-string is proper
            End If
        Else
            preString = StrConv(preString, 3) 'No lower case found, Caps Lock stuck;
            postString = StrConv(postString, 3) 'Reduce the entire string to proper
        End If
        fProper = preString & postString 'Add the two elements together
     Else
 
         'No space was found, a reasonable assumption as to case can't be made;.
         'pass the string back unaltered.
         fProper = strText
     End If
End Function

Sub ConvertToUppercaseText() 'Converts lower case to upper case in cell selection. Macro to Change All Text in a Range to Uppercase Letters
    Dim Rng As Range
    For Each Rng In Selection.Cells
        If Rng.HasFormula = False Then
             'Use this line for UpperCase text; change UCase to LCase for LowerCase text.
            Rng.Value = UCase(Rng.Value)
        End If
    Next Rng
End Sub

Sub ConvertToLowercaseText() 'Converts Uppercase to lowercase text in cell selection. Macro to Change All Text in a Range to Lowercase Letters
    Dim Rng As Range
    For Each Rng In Selection.Cells 'sets range as selection
        If Rng.HasFormula = False Then
             'Use this line for UpperCase text; change UCase to LCase for LowerCase text.
            Rng.Value = LCase(Rng.Value)
        End If
    Next Rng
End Sub

Sub ConverttoSentanceCase() 'Macro to Change All Text in a Cell Range to Initial Capital Letters
   
 Dim Rng As Range
   ' Loop to cycle through each cell in the specified range.
   For Each Rng In Selection.Cells
      ' There is not a Proper function in Visual Basic for Applications.
      ' So, you must use the worksheet function in the following form:
      Rng.Value = Application.Proper(Rng.Value) 'rng is the Dim Value - I.e. if see x.value can replace x with rng which is Dim Value
   Next
End Sub

Sub Trim_Cells_Array_Method()

Dim arrData() As Variant
Dim arrReturnData() As Variant
Dim Rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long

  lRows = Selection.Rows.Count
  lCols = Selection.Columns.Count

  ReDim arrData(1 To lRows, 1 To lCols)
  ReDim arrReturnData(1 To lRows, 1 To lCols)

  Set Rng = Selection
  arrData = Rng.Value

  For j = 1 To lCols
    For i = 1 To lRows
      arrReturnData(i, j) = Trim(arrData(i, j))
    Next i
  Next j

  Rng.Value = arrReturnData

  Set Rng = Nothing
End Sub

Sub RemoveLineBreaks() 'If you Just want ALL line Breaks gone use this. This removes carridgeway returns from selection
    Application.ScreenUpdating = False
    Dim rngCel As Range
    Dim strOldVal As String
    Dim strNewVal As String

    For Each rngCel In Selection
        If rngCel.HasFormula = False Then
            strOldVal = rngCel.Value
            strNewVal = strOldVal
            Debug.Print rngCel.Address

            Do

            strNewVal = Replace(strNewVal, vbLf, " ") ' replace new lines with blank space, can change to other items

            If strNewVal = strOldVal Then Exit Do
                strOldVal = strNewVal
            Loop

            If rngCel.Value <> strNewVal Then
                rngCel = strNewVal
            End If
        End If
        rngCel.Value = Application.Trim(rngCel.Value)
    Next rngCel
    Application.ScreenUpdating = True
End Sub

Sub Extracthyperlinks()
'Updateby Extendoffice
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "Extract URL"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each Rng In WorkRng
    If Rng.Hyperlinks.Count > 0 Then
        Rng.Value = Rng.Hyperlinks.Item(1).Address
    End If
Next
End Sub

Sub FillColBlanks_Offset()
'by Rick Rothstein  2009-10-24
'fill blank cells in column with value above
'http://www.contextures.com/xlDataEntry02.html

  Dim Area As Range, LastRow As Long
  On Error Resume Next
  LastRow = Cells.Find(What:="*", SearchOrder:=xlRows, _
               SearchDirection:=xlPrevious, _
               LookIn:=xlFormulas).Row
  For Each Area In ActiveCell.EntireColumn(1).Resize(LastRow). _
               SpecialCells(xlCellTypeBlanks).Areas
    Area.Value = Area(1).Offset(-1).Value
  Next
End Sub

Sub TrimText()

  Dim c As Range
  Dim AppCalcMode As XlCalculation

  Application.ScreenUpdating = False
  AppCalcMode = Application.Calculation
  Application.Calculation = xlCalculationManual

  For Each c In Selection.Cells
    c.Value2 = Trim(c.Value2)
  Next c
  
  Application.Calculation = AppCalcMode
  Application.ScreenUpdating = True
  
End Sub

Sub FillToRight() '(Ctrl+Shift+R)
'declare variables
TotalCols = ActiveCell.CurrentRegion.Columns.Count
CurrentCol = ActiveCell.Column
ColsToFill = TotalCols - CurrentCol
'declare starting cell and ending cell
cellSource = ActiveCell.Address
cellTarget = Cells(ActiveCell.Row, ActiveCell.Column + ColsToFill).Address
'check that activecell is not blank
If ActiveCell.Value = "" Then
GoTo skip_fill_1
End If
'check for completed cells in other columns of active row
CompletedCells = Application.WorksheetFunction.CountA(Range(cellSource, cellTarget))
If CompletedCells <> 1 Then
GoTo skip_fill_2
End If
'fill to right
On Error GoTo skip_fill_3
Selection.AutoFill Destination:=Range("" & cellSource & ":" & cellTarget & ""), Type:=xlFillDefault
Range("" & cellSource & ":" & cellTarget & "").Select
Exit Sub
'error traps
skip_fill_1:
MsgBox "Unable to fill right - active cell is blank", vbCritical, "ERROR"
Exit Sub
skip_fill_2:
MsgBox "Unable to fill right - other data exists on this row", vbCritical, "ERROR"
Exit Sub
skip_fill_3:
MsgBox "Unable to fill right - unspecified error", vbCritical, "ERROR"
Exit Sub
End Sub

Sub TidyEmailAddress() '(Ctrl+Shift+E)'Tidy's up email addresses
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'
Selection.ClearFormats
Selection.Hyperlinks.Delete
Selection.Replace What:="mailto:", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="] ", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:=">", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:=Chr(160), Replacement:=" ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'remove email "name" from before email address
For Each c In Selection
c.Value = LCase(c)
start_pos = 0
On Error Resume Next
start_pos = Application.WorksheetFunction.Search("<", c)
If start_pos <> 0 Then
c.Value = Right(c, Len(c) - start_pos)
End If
Next c
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
End Sub

Private Sub MergeProjectNameColumns()
' I had two columns, A & B. I wanted to move B over only if A was blank. See below. It is based on a selection Range, which you could use to offset the first row, perhaps.
    Dim rngRowCount As Integer
    Dim i As Integer

    'Loop through column C and simply copy the text over to B if it is not blank
    rngRowCount = Range(DataRange).Rows.Count
    ActiveCell.Offset(0, 0).Select
    ActiveCell.Offset(0, 2).Select
    For i = 1 To rngRowCount
        If (Len(RTrim(ActiveCell.Value)) > 0) Then
            Dim currentValue As String
            currentValue = ActiveCell.Value
            ActiveCell.Offset(0, -1) = currentValue
        End If
        ActiveCell.Offset(1, 0).Select
    Next i

    'Now delete the unused column
    Columns("C").Select

    Selection.Delete Shift:=xlToLeft
End Sub

Sub Extracthyperlinks()
'Updateby Extendoffice
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "Extract URL"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each Rng In WorkRng
    If Rng.Hyperlinks.Count > 0 Then
        Rng.Value = Rng.Hyperlinks.Item(1).Address
    End If
Next
End Sub