Excel Macros

macros

Sub Worksheet_SelectionChange(ByVal Target As range)
    If TypeName(Target) = "Range" Then
        If Target.Cells.Count > 1 Then
            Application.StatusBar = "# of Characters: " & _
                                    Application.Evaluate( _
                                                          "=MAX(LEN(" & _
                                                           Target.Address & _
                                                           ":" & _
                                                           Target.Address & _
                                                           "))" _
                                                           )
        End If
    End If
End Sub

Sub Auto_Columns()
' Auto Bold Resize Filter and Freeze
'
'
    Rows("1:1").Select
    Selection.AutoFilter
    Selection.Font.Bold = True
    Columns("A:IV").AutoFit
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
End Sub

Sub Named_Range()
'
' Named_Range Macro
'
' Keyboard Shortcut: Ctrl+Shift+R
'
    Dim ActSheet As Worksheet
    Dim ActSheetName As String
'This sets up an object reference to the activesheet
    Set ActSheet = Sheets(ActiveSheet.Name)
'This places a string value in the variable
    ActSheetName = ActiveSheet.Name
 
    Set wb = ActiveWorkbook
    Set WS = ActiveSheet
    Set sheetname = ActiveWorkbook.ActiveSheet
    WS.range("A1").Select
    ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:= _
        "=OFFSET(R1C1,0,0,COUNTA(C1),COUNTA(R1))"
    wb.Names("data").Name = ActSheetName
 
End Sub

Sub Save_as_pdf()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
    Dim FSO As Object
    Dim s(1) As String
    Dim sNewFilePath As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    s(0) = ActiveWorkbook.FullName
 
    If FSO.FileExists(s(0)) Then
        '//Change Excel Extension to PDF extension in FilePath
        s(1) = FSO.GetExtensionName(s(0))
        If s(1) <> "" Then
            s(1) = "." & s(1)
            sNewFilePath = Replace(s(0), s(1), ".pdf")
 
            '//Export to PDF with new File Path
            ActiveSheet.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=sNewFilePath, _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, OpenAfterPublish:=True
        End If
    Else
        '//Error: file path not found
        MsgBox "Error: this workbook may be unsaved.  Please save and try again."
    End If
 
    Set FSO = Nothing
End Sub


Sub Auto_Pivot()
'
' Change Name
'

    ActiveSheet.Name = "data"
'
' Fix Columns
'
    Rows("1:1").Select
    Selection.AutoFilter
    Selection.Font.Bold = True
    Columns("A:IV").AutoFit
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

'
' Named Range
'
    Dim ActSheet As Worksheet
    Dim ActSheetName As String
    Set ActSheet = Sheets(ActiveSheet.Name)
    ActSheetName = ActiveSheet.Name
    Set wb = ActiveWorkbook
    Set WS = ActiveSheet
    Set sheetname = ActiveWorkbook.ActiveSheet
    WS.range("A1").Select
    ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:= _
        "=OFFSET(R1C1,0,0,COUNTA(C1),COUNTA(R1))"
    wb.Names("data").Name = ActSheetName

'
' Pivot Table
'

    Set WS = Sheets.Add().Name = "Pivot"
    Sheets("Pivot").Select
    range("A1").Select
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "data", Version:=xlPivotTableVersion14).CreatePivotTable TableDestination:= _
        "Sheet1!R1C1", TableName:="PivotTable5", DefaultVersion:= _
        xlPivotTableVersion14
    Sheets("Sheet1").Select
    Cells(1, 1).Select
    
End Sub



Function Discount(quantity, price)
 If quantity >= 100 Then
 Discount = quantity * price * 0.1
 Else
 Discount = 0
 End If
 Discount = Application.Round(Discount, 2)
End Function

Function custom_concat(range As range, delimiter As String)
    Dim eleme As Variant
    Dim new_value As String
    Dim cell As range
    Dim rng As range
    
    
    For Each cell In range
        new_value = new_value + cell.value + delimiter
        
    Next cell

    custom_concat = new_value
End Function