Formatting

Sub AddBlankRows_ColumnA() 'How to automatically insert a blank row after a group of data
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Range("D1") ' Column to review for group of data

iRow = oRng.Row
iCol = oRng.Column

Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).EntireRow.Insert Shift:=xlDown
    iRow = iRow + 2
Else
    iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, iCol).Text = ""
'
End Sub

Sub AddBlankRows_ColumnSelectedbyUser() 'How to automatically insert a blank row after a group of data based on column selected by the User - i.e. active cell
'The Cells(row,column) command allows you to stipulate which cell a range to to extend from "MyRow = ActiveCell.Row", "MyCol = ActiveCell.Column". Both these commands allow the program to identify what row or column the mouse is on
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Cells(1, ActiveCell.Column) 'Selects first cell e.g. "A1" in selected column to enable the function to perform task) ' Column to review for group of data

iRow = oRng.Row
iCol = oRng.Column

Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).EntireRow.Insert Shift:=xlDown
    iRow = iRow + 2
Else
    iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, iCol).Text = ""
'
End Sub

Sub AddBlankRows_RangeSelectedbyUser() 'How to automatically insert a blank row after a group of data based on column selected by the User - i.e. active cell
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Application.Selection 'Sets range (in this case the column) as the user selected range - I.e. this is what application.selection does

iRow = oRng.Row
iCol = oRng.Column

Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).EntireRow.Insert Shift:=xlDown
    iRow = iRow + 2
Else
    iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, iCol).Text = ""
'
End Sub

Sub InsertRowsAtIntervals() ' Inserts X number of rows at X number of intervals per message dialog
'Updateby20150707
Dim Rng As Range
Dim xInterval As Integer
Dim xRows As Integer
Dim xRowsCount As Integer
Dim xNum1 As Integer
Dim xNum2 As Integer
Dim WorkRng As Range
Dim xWs As Worksheet
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
xRowsCount = WorkRng.Rows.Count
xInterval = Application.InputBox("Enter row interval. ", xTitleId, 1, Type:=1)
xRows = Application.InputBox("How many rows to insert at each interval? ", xTitleId, 1, Type:=1)
xNum1 = WorkRng.Row + xInterval
xNum2 = xRows + xInterval
Set xWs = WorkRng.Parent
For i = 1 To Int(xRowsCount / xInterval)
    xWs.Range(xWs.Cells(xNum1, WorkRng.Column), xWs.Cells(xNum1 + xRows - 1, WorkRng.Column)).Select
    Application.Selection.EntireRow.Insert
    xNum1 = xNum1 + xNum2
Next
End Sub

Sub InsertARow() 'Inserting Multiple Rows Between Existing Rows of Data
Dim j As Long
Dim r As Range
j = InputBox("Enter the number of rows to be inserted")
Set r = Range("A2") 'set range
Do While r.Value <> ""
    Set r = r.Offset(1, 0)
    For i = 1 To j
        r.EntireRow.Insert
    Next
Loop

End Sub

Sub ClearANDSetNewFormat_WordWrap_Top_Alignment()
'
' Macro1 Macro
'

'
    Selection.ClearFormats 'clears the formats from the selection
    With Selection 'sets new format
        .HorizontalAlignment = xlGeneral ' sets horizontal alignment to default
        .VerticalAlignment = xlTop 'sets verticle alignment to top
        .WrapText = True 'Sets wordwrap to on
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

Sub DeleteAllPictures() 'Deletes all pictures in a workbook (say from a converted document) in the active document

ActiveSheet.Pictures.Delete

End Sub

' Also bolds the top row, scrolls to the top left corner of the sheet, and autofits columns (with a maximum width so some text columns don’t get ridiculous).
' Active sheet: Prep for quick viewing
' Scroll to top-left corner, freeze top row, bold top row, AutoFit columns
Sub SetUp_NiceView()
    
    ' Declare variables
    Dim rowLast         As Long
    Dim colLast         As Integer
    Dim i               As Integer
    
    ' Maximum column width when AutoFitting columns
    ' Value needs to be in points (you can see the points when clicking-and-dragging to resize a column)
    Const maxColWidth   As Double = 35.86 ' 256 pixels
    
    ' Set up nice view!
    With ActiveSheet
        ' Unhide all cells
         On Error Resume Next
        .ShowAllData
        .Cells.EntireRow.Hidden = False
        .Cells.EntireColumn.Hidden = False
        On Error GoTo 0
        
        ' Get last row and column
        ' Excel's Find function remembers the last settings used: Search rows second so the Find function remembers to search by row
        On Error Resume Next
        colLast = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        rowLast = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        On Error GoTo 0
        
        ' If you don't want the code to unhide all cells, use these definitions instead:
        ' colLast = .UsedRange.Columns.Count
        ' rowLast = .UsedRange.Rows.Count
        
        If rowLast = 0 Or colLast = 0 Then Exit Sub
        
        ' Bold top row
        .Range(.Cells(1, 1), .Cells(1, colLast)).Font.Bold = True
        
        ' Freeze top row
        ActiveWindow.FreezePanes = False
        Application.GoTo .Cells(2, 1), True
        ActiveWindow.ScrollRow = 1
        ActiveWindow.FreezePanes = True
        .Cells(1, 1).Select
        
        ' Disable AutoFilter if it's on
        .AutoFilterMode = False
        
        ' AutoFilter top row
        With .Range(.Cells(1, 1), .Cells(rowLast, colLast))
            .AutoFilter
            
            ' AutoFit columns
            .Columns.AutoFit
            
            ' Loop through each column
            ' If any have exceed the max width, try AutoFitting just the header
            ' If the column still exceeds the max width, set it to the max width
            For i = 1 To colLast
                If .Columns(i).ColumnWidth > maxColWidth Then
                    .Columns(i).Cells(1).Columns.AutoFit
                    
                    If .Columns(i).ColumnWidth > maxColWidth Then
                        .Columns(i).ColumnWidth = maxColWidth
                    End If
                End If
            Next i
        End With
    End With
    
End Sub

Sub KillStyles()

' Style Killer. Deletes all custom styles that get randomly added into workbooks. It stops the file getting bloated with 200+ styles, preventing you from copying and pasting information later.

    Dim styT As Style

    'CONFIRMATION THAT YOU WANT TO DELETE STYLES
    If MsgBox("There are: " & ActiveWorkbook.Styles.Count - 47 & " custom styles." & vbNewLine & vbNewLine & _
    "Delete?", vbInformation + vbYesNo) <> vbYes Then Exit Sub
    
    'STATUS BAR UPDATE SO YOU KNOW WHAT'S HAPENNING AND HOW LONG ITS BEEN
    Application.StatusBar = "Deleting styles: Started: " & Time
    
    'ONE SECOND GAP GIVING YOU TIME TO BREAK IF NECESSARY
    Application.Wait Now + (#12:00:01 AM#)
    
    For Each styT In ActiveWorkbook.Styles
    
        If Not styT.BuiltIn Then styT.Delete
    
    Next styT

    'CLEAR STATUS BAR
    Application.StatusBar = False
    
End Sub

Sub ConvertTextToNumber()

' A converter to change all numbers stored as text in to numbers in one go.

    Dim c As Range

    'IF YOU HAVE A SELECTION, THEN CONVERT ONLY THE SELECTION
    If Selection.Count > 1 Then
        
        For Each c In Selection
            If IsNumeric(c) And c <> "" Then c.Value = Val(c.Value)
        Next
    
    Else
    'IF NO SELECTION IS MADE, THEN CONVERT EVERY CELL WITHIN THE USED RANGE
        For Each c In ActiveSheet.UsedRange
            If IsNumeric(c) And c <> "" Then c.Value = Val(c.Value)
        Next
    
    
    End If


End Sub

Sub ConverToText()

    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 = Chr(39) & c.Value2
    Next c

    Application.Calculation = AppCalcMode
    Application.ScreenUpdating = True

End Sub

Sub toggle_case_shortcut() 'Ctrl+Shift+C 'Toggle Text Case
'IS UPPER CASE - convert to lower case"
If ActiveCell.Value = UCase(ActiveCell) Then
Dim rngRectangle As Range, rngRows As Range, rngcolumns As Range
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),lower(" & rngRectangle.Address & ")))")
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
'is lower case - convert to Proper Case"
ElseIf ActiveCell.Value = LCase(ActiveCell) Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Selection.Replace What:="-", Replacement:=" - ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="'", Replacement:=" ' ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="`", Replacement:=" ' ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="  ' t", Replacement:=" 't", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),trim(" & rngRectangle.Address & ")))")
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),proper(" & rngRectangle.Address & ")))")
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Ii"",REPLACE(@,LEN(@)-2,3,"" II""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,4)="" Iii"",REPLACE(@,LEN(@)-2,4,"" III""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Iv"",REPLACE(@,LEN(@)-2,3,"" IV""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Vi"",REPLACE(@,LEN(@)-2,3,"" VI""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,4)="" Vii"",REPLACE(@,LEN(@)-2,4,"" VII""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,5)="" Viii"",REPLACE(@,LEN(@)-2,5,"" VIII""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Ix"",REPLACE(@,LEN(@)-2,3,"" IX""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Mp"",REPLACE(@,LEN(@)-2,3,"" MP""),@)", "@", Selection.Address))
Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows
For Each c In Selection
If UCase(Left(c, 2)) = "MC" And Mid(c, 3, 1) <> "" Then
c.Value = Application.Proper(Left(c, 2)) & Application.Proper(Mid(c, 3, Len(c) - 2))
End If
Next c
Selection.Replace What:=" - ", Replacement:="-", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:=" ' ", Replacement:="'", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="1St", Replacement:="1st", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="2Nd", Replacement:="2nd", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="3Rd", Replacement:="3rd", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="4Th", Replacement:="4th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="5Th", Replacement:="5th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="6Th", Replacement:="6th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="7Th", Replacement:="7th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="8Th", Replacement:="8th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="9Th", Replacement:="9th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="10Th", Replacement:="10th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="11Th", Replacement:="11th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="12Th", Replacement:="12th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="13Th", Replacement:="13th", LookAt:=xlPart, MatchCase:=True
If Left(cel, 1) <> "0" Then
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),clean(" & rngRectangle.Address & ")))")
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),trim(" & rngRectangle.Address & ")))")
End If
Application.DisplayAlerts = True
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
'IS Proper Case - convert to UPPER CASE"
Else
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),upper(" & rngRectangle.Address & ")))")
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
End If
End Sub

Sub Insert_Lines10() 'Insert 10 blank lines
    For i = 1 To 10
        Selection.Insert Shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
    Next i
End Sub

Sub Insert_Lines() ' Insert Custom Number of blank rows
Dim HowManyRows As Long
HowManyRows = InputBox("How many Rows?")
    For i = 1 To HowManyRows
        Selection.Insert Shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
    Next i
End Sub

Sub ConditionalHighlightCells()

'Select a range of cells, then use the following code to highlight cells that contain a specified string

 

Set rngMine = Selection

For Each c In rngMine

     'highlight the cell containing "error"
    If InStr(1, c.Value, "error", vbTextCompare) Then 'I use InStr here (contains), but you can use c.value="error" for an exact match
        With c.Interior
            .Color = 65535 'yellow
            'Another format that can be used
            '.Color = RGB(200, 200, 255) ' RGB is Red, Green, Blue
            .Pattern = xlSolid
        End With
    End If
Next c

 

 End Sub

Sub MakeOneColumn_Transpose()


    Dim vaCells As Variant
    Dim vOutput() As Variant
    Dim i As Long, j As Long
    Dim lRow As Long

    If TypeName(Selection) = "Range" Then
        If Selection.Count > 1 Then
            If Selection.Count <= Selection.Parent.Rows.Count Then
                vaCells = Selection.Value

                ReDim vOutput(1 To UBound(vaCells, 1) * UBound(vaCells, 2), 1 To 1)

                For j = LBound(vaCells, 2) To UBound(vaCells, 2)
                    For i = LBound(vaCells, 1) To UBound(vaCells, 1)
                        If Len(vaCells(i, j)) > 0 Then
                            lRow = lRow + 1
                            vOutput(lRow, 1) = vaCells(i, j)
                        End If
                    Next i
                Next j

                Selection.ClearContents
                Selection.Cells(1).Resize(lRow).Value = vOutput
            End If
        End If
    End If

End Sub