Snippets Collections
= Table.combine({#"Replaced Value",'#"Import - VenSafe - Quality Events"})
= Table.TransformColumns(#"Changed Type", {{"Audit Url", each Text.Insert(_, 0, “https://app.solv.com.au/#/app/safety/eventdashboard/”), type text}})
import tabula
df = tabula.read_pdf(r'C:\Users\igrod\Downloads\tabela nieruchomosci.pdf', pages='all')
tabula.convert_into(r'C:\Users\igrod\Downloads\tabela nieruchomosci.pdf', r'C:\Users\igrod\Downloads\tabela nieruchomosci.csv', output_format="csv", pages='all')
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 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
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
Public Sub Sheet_Select(Sheet_Name As String, Dest As String, Del_Sheet As Boolean)
' This checks that a sheet exists and then switches to it positioning into the specified column and in the first empty cell.
    Dim flag As Boolean
    Dim ws As Worksheet
    
    Application.DisplayAlerts = False
    flag = "False"
    For Each ws In ActiveWorkbook.Sheets
        If ws.Name = Sheet_Name Then
            If Del_Sheet Then
                Sheets(Sheet_Name).Delete
            Else
                flag = "True"
            End If
        End If
    Next ws
    If Not flag Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = Sheet_Name
    Sheets(Sheet_Name).Select
    Cells(Rows.Count, Dest).End(xlUp).Offset(Abs(Cells(Rows.Count, Dest).End(xlUp).Value <> ""), 0).Select
    Application.DisplayAlerts = True
End Sub
Sub FilterSelectedValues()
' This last one is used for filtering multiple values in a table. You paste the values you want to filter right below your table, then run the macro.
    Dim arrayEn() As Variant
    Dim selCol As Integer
    Dim rCell As Range
    Dim i As Long

    ReDim arrayEn(1 To 1, 1 To Selection.Count)
    selCol = Selection.Column
    i = 1

    For Each rCell In Selection
       arrayEn(1, i) = CStr(rCell.Value2)
       i = i + 1
    Next rCell

    ActiveSheet.Range("A1").AutoFilter field:=selCol, Criteria1:=arrayEn, Operator:=xlFilterValues
End Sub
Sub ToggleR1C1() 'Toggles cell referencing style:
'http://blog.contextures.com/archives/2009/12/04/excel-vba-switch-column-headings-to-numbers/
   If Application.ReferenceStyle = xlA1 Then
        Application.ReferenceStyle = xlR1C1
    Else
        Application.ReferenceStyle = xlA1
    End If
End Sub
Sub SelectionToUniqueValuesInNewWB() 'To get unique values from one column into new workbook:
    Selection.Copy
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteValues
    Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
Public Sub RecalculateSelection()
' I work with a lot of really large workbooks and worksheets and one of my very favorite easy macros is this one. I generally always have to have manual calculations on and sometimes larger worksheets are still slow. This macro allows you to refresh only selected cells.

    If TypeName(Selection) = "Range" Then Selection.Calculate
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 Insert_Lines10() 'Insert 10 blank lines
    For i = 1 To 10
        Selection.Insert Shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
    Next i
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 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
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 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 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 swapTableReferences(formulaRange As Range)
'Switches table references in cells in range based on first table reference in each cell, ie:
    'If first table reference in a cell is relative, references are changed to fixed
    'If first table reference in a cell is fixed, references are changed to relative
    
    Dim c As Range
    Dim fText As String
    Dim tempText As String
    Dim colName As String
    Dim startStr As String
    Dim startBracket As Long
    Dim endBracket As Long
    Dim screenUp As Boolean
    
    screenUp = Application.ScreenUpdating
    
    If screenUp Then
        Application.ScreenUpdating = False
    End If
    
    For Each c In formulaRange
        fText = c.Formula
        tempText = ""
        goAhead = False
        If Mid(fText, InStr(fText, "]") + 1, 1) = ":" Then
            invert = True
        Else
            invert = False
        End If
        Do Until goAhead = True
            startBracket = InStr(fText, "[")
            endBracket = InStr(fText, "]")
            If startBracket = 0 Or endBracket = 0 Or endBracket < startBracket Then
                tempText = tempText & fText
                goAhead = True
            ElseIf Mid(fText, startBracket + 1, 1) = "[" Or Mid(fText, endBracket + 1, 1) = ":" Then
                If invert = False Or Mid(fText, startBracket + 2, 1) = "#" Then
                    endBracket = InStr(endBracket + 1, fText, "]")
                    tempText = tempText & Left(fText, endBracket + 1)
                    fText = Right(fText, Len(fText) - endBracket - 1)
                Else
                    If Mid(fText, endBracket + 1, 1) = ":" Then
                        colName = Mid(fText, startBracket + 3, endBracket - startBracket - 3)
                        tempText = tempText & Left(fText, startBracket - 1) & "[@[" & colName & "]]"
                    Else
                        colName = Mid(fText, startBracket + 2, endBracket - startBracket - 2)
                        tempText = tempText & Left(fText, startBracket - 1) & "[" & colName & "]"
                    End If
                    fText = Right(fText, Len(fText) - InStr(endBracket + 1, fText, "]") - 1)
                End If
            ElseIf invert = False Then
                If Mid(fText, startBracket + 1, 1) = "@" Then
                    If Mid(fText, startBracket + 2, 1) = "[" Then
                        endBracket = endBracket + 1
                        colName = Mid(fText, startBracket + 3, endBracket - startBracket - 4)
                    Else
                        colName = Mid(fText, startBracket + 2, endBracket - startBracket - 2)
                    End If
                    startStr = "[@["
                Else
                    colName = Mid(fText, startBracket + 1, endBracket - startBracket - 1)
                    startStr = "[["
                End If
                tempText = tempText & Left(fText, startBracket - 1) & startStr & colName & "]:[" & colName & "]]"
                fText = Right(fText, Len(fText) - endBracket)
            ElseIf (Mid(fText, startBracket + 1, 1) = "@") And (Mid(fText, startBracket + 2, 1) = "[") Then
                If Mid(fText, endBracket + 1, 1) = "]" Then
                    tempText = tempText & Left(fText, endBracket + 1)
                    fText = Right(fText, Len(fText) - endBracket - 1)
                Else
                    colName = Mid(fText, startBracket + 3, endBracket - startBracket - 3)
                    tempText = tempText & Left(fText, startBracket - 1) & "[@[" & colName & "]]"
                    fText = Right(fText, Len(fText) - InStr(endBracket + 1, fText, "]") - 1)
                End If
            Else
                tempText = tempText & Left(fText, endBracket)
                fText = Right(fText, Len(fText) - endBracket)
            End If
        Loop
        If Not tempText = fText Then
            c.Formula = tempText
        End If
    Next
    
    If screenUp Then
        Application.ScreenUpdating = True
    End If
        
End Sub
Sub swapSelectedTableReferences()
'Version to map to hotkey for working with selections
    Call swapTableReferences(ActiveSheet.Range(Selection.Address))
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 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
' 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
Private Sub Worksheet_Change(ByVal Target As Range) 'Filter Data From Drop Down List Selection In Two Worksheets With VBA Code. If your drop down list cell in Sheet1, and the filtered data in Sheet2, when choosing one item from the drop down list, another sheet will be filtered out.
'Updateby Extendoffice
'Note: In the above code: A2 is the cell which contains the drop down list, and Sheet2 is the worksheet contains the data you want to filter. The number 1 in the script: AutoFilter 1 is the column number that you want to filter based on. You can change them to your need.
' 2. From now on, when you select one item from the drop down list in Sheet1, and the corresponding data will be filtered out in Sheet2, see screenshot:
    On Error Resume Next
    If Not Intersect(Range("A2"), Target) Is Nothing Then
        Application.EnableEvents = False
        If Range("A2").Value = "" Then
            Worksheets("Sheet2").ShowAllData
        Else
            Worksheets("Sheet2").Range("A2").AutoFilter 1, Range("A2").Value
        End If
        Application.EnableEvents = True
    End If
End Sub
Sub combinationFilter() 'Filtering based on selected combination
    Dim cell As Range, tableObj As ListObject, subSelection As Range
    Dim filterCriteria() As String, filterFields() As Integer
    Dim i As Integer
    
    'If the selection is in a table and one row height
        
    If Not Selection.ListObject Is Nothing And Selection.Rows.Count = 1 Then
        Set tableObj = ActiveSheet.ListObjects(Selection.ListObject.Name)
        
        i = 1
        ReDim filterCriteria(1 To Selection.Cells.Count) As String
        ReDim filterFields(1 To Selection.Cells.Count) As Integer
        
        ' handle multi-selects
        
        For Each subSelection In Selection.Areas
            For Each cell In subSelection
                filterCriteria(i) = cell.Text
                filterFields(i) = cell.Column - tableObj.Range.Cells(1, 1).Column + 1
                i = i + 1
            Next cell
        Next subSelection
        
        With tableObj.Range
            For i = 1 To UBound(filterCriteria)
                .AutoFilter field:=filterFields(i), Criteria1:=filterCriteria(i)
            Next i
        End With
        Set tableObj = Nothing
    End If
End Sub
Sub NormalizeData() ' Not very good, perhaps look to replace
Dim Rng As Range
Dim ws As Worksheet
 
On Error Resume Next
Set Rng = Application.InputBox(Prompt:="Select a range to normalize data" _
, Title:="Select a range", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0
 
If Rng Is Nothing Then
Else
    Application.ScreenUpdating = False
    Set ws = Sheets.Add
    i = 0
    For r = 1 To Rng.Rows.Count - 1
        For c = 1 To Rng.Columns.Count - 1
            ws.Range("A1").Offset(i, 0) = Rng.Offset(0, c).Value
            ws.Range("A1").Offset(i, 1) = Rng.Offset(r, 0).Value
            ws.Range("A1").Offset(i, 2) = Rng.Offset(r, c).Value
            i = i + 1
        Next c
    Next r
    ws.Range("A:C").EntireColumn.AutoFit
    Application.ScreenUpdating = True
End If
End Sub
Sub DeleteAllPictures() 'Deletes all pictures in a workbook (say from a converted document) in the active document

ActiveSheet.Pictures.Delete

End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'These need to be added into the worksheet VBA section itself
'Enter a price in column B and a formula is instantly entered in column C.
' Formula in column c: Cell value in column B multiplied by 1.1

Dim lRow As Single
Dim AStr As String
Dim Value As Variant
If Not Intersect(Target, Range("B:B")) Is Nothing Then
    For Each Value In Target
        If Value <> "" Then
            Range("C" & Value.Row).Formula = "=" & Target.Address & "*1.1"
        End If
    Next Value
End If
End Sub
Private Sub Worksheet_ChangeTimestamp(ByVal Target As Range)
'These need to be added into the worksheet VBA section itself
'Enter a name in column A and current date and time is entered automatically in column B. You can also copy a cell range and paste in column A. Empty cells are not processed.
Dim Value As Variant
If Not Intersect(Target, Range("A:A")) Is Nothing Then
    For Each Value In Target
        If Value <> "" Then
            Range("B" & Value.Row).Value = Now
        End If
    Next Value
End If
End Sub
Sub CopyNonContiguousSelections() 'How to copy non contiguous cell ranges
Set cellranges = Application.Selection 'Sets the Selected Cell as the cell range
Set ThisRng = Application.InputBox("Select a destination cell", "Where to paste slections?", Type:=8)
For Each cellrange In cellranges.Areas
    cellrange.Copy ThisRng.Offset(i)
    i = i + cellrange.Rows.CountLarge
Next cellrange
End Sub

'https://www.get-digital-help.com/2018/05/29/how-to-copy-non-contiguous-cell-ranges/
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 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 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 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 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 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 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 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
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 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 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 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 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_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 FolderCreator()

    Dim objRow As Range, objCell As Range, strFolders As String, rootFolder As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        ' show the file picker dialog box
        If .Show <> 0 Then
            rootFolder = .SelectedItems(1)
              End If
    End With

    For Each objRow In ActiveSheet.UsedRange.Rows
        strFolders = rootFolder
        For Each objCell In objRow.Cells
            strFolders = strFolders & "\" & objCell
        Next
        Shell ("cmd /c md " & Chr(34) & strFolders & Chr(34))
    Next

End Sub
Sub GetColourHex()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim str0 As String, str As String
Dim cel As Range
For Each cel In Selection
str0 = Right("000000" & Hex(cel.Interior.Color), 6)
str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
cel = "#" & str & ""
Next cel
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
'Example use of the iColor function to get the background color of selected cells
Sub Get_Background_Color_Selection_Cells()
    Dim Rng As Range

    For Each Rng In Selection.Cells
        Rng.Offset(0, 1).Value = iColor(Rng, "HEX")
        Rng.Offset(0, 2).Value = iColor(Rng, "RGB")
    Next
End Sub
Public Function iColor(Rng As Range, Optional formatType As String) As Variant ' Linked with Get_Background_Colour_selection_cells Function Below
'formatType: Hex for #RRGGBB, RGB for (R, G, B) and IDX for VBA Color Index
    Dim colorVal As Variant
    colorVal = Rng.DisplayFormat.Interior.Color
    Select Case UCase(formatType)
        Case "HEX"
            iColor = "#" & Hex(colorVal Mod 256) & Hex((colorVal \ 256) Mod 256) & Hex((colorVal \ 65536))
        Case "RGB"
            iColor = (colorVal Mod 256) & ", " & ((colorVal \ 256) Mod 256) & ", " & (colorVal \ 65536)
        Case "IDX"
            iColor = Rng.Interior.ColorIndex
        Case Else
            iColor = colorVal
    End Select
End Function
Sub GetRGBColor_Font()
'PURPOSE: Output the RGB color code for the ActiveCell's Font Color
'SOURCE: www.TheSpreadsheetGuru.com

Dim HEXcolor As String
Dim RGBcolor As String

HEXcolor = Right("000000" & Hex(ActiveCell.Font.Color), 6)

RGBcolor = "RGB (" & CInt("&H" & Right(HEXcolor, 2)) & _
", " & CInt("&H" & Mid(HEXcolor, 3, 2)) & _
", " & CInt("&H" & Left(HEXcolor, 2)) & ")"

MsgBox RGBcolor, vbInformation, "Cell " & ActiveCell.Address(False, False) & ":  Font Color"

End Sub
Sub GetRGBColor_Fill()
'PURPOSE: Output the RGB color code for the ActiveCell's Fill Color
'SOURCE: www.TheSpreadsheetGuru.com

Dim HEXcolor As String
Dim RGBcolor As String

HEXcolor = Right("000000" & Hex(ActiveCell.Interior.Color), 6)

RGBcolor = "RGB (" & CInt("&H" & Right(HEXcolor, 2)) & _
", " & CInt("&H" & Mid(HEXcolor, 3, 2)) & _
", " & CInt("&H" & Left(HEXcolor, 2)) & ")"

MsgBox RGBcolor, vbInformation, "Cell " & ActiveCell.Address(False, False) & ":  Fill Color"

End Sub
Sub AddorChangeCellValueBasedOnCellColor() ' Fill in cells based on defined cell colour
    Dim rg As Range
    Dim xRg As Range
    Set xRg = Selection.Cells
    Application.DisplayAlerts = False
    For Each rg In xRg
        With rg
            Select Case .Interior.Color
                Case Is = RGB(255, 0, 0) 'Red
                    .Value = "Remove" 'Can simply replace with number
                Case Is = RGB(146, 208, 80) 'Light Green
                    .Value = "Add" 'Can also replace the Add simply replace with number no quotation marks
            End Select
        End With
    Next
    Application.DisplayAlerts = False
End Sub
= Table.AddColumn(#"Removed Columns2", "The Auditor", each if [Lead Auditor] <> "" then [Lead Auditor] else if [Internal Auditor] <> "" then [Internal Auditor] else if [External Auditor Name] <> "" then [External Auditor Name] else "Unknown")
# Actions - Status All (fix) = SWITCH(
    TRUE(),
    '2 Non-conformances - Combined'[# Actions - Assigned]="Assigned" && '2 Non-conformances - Combined'[# Actions - Not Complete (outcome works, source data needs correction)]=0, "Completed",
    '2 Non-conformances - Combined'[# Actions - Assigned]="Assigned" && '2 Non-conformances - Combined'[# Actions - Not Complete (outcome works, source data needs correction)]>=1, "Not Completed",
    '2 Non-conformances - Combined'[# Actions - Assigned]="Not Assigned", "Pending",
    "Other"
)
Table =
FILTER (
    UNION (
        SELECTCOLUMNS ( Tab1, "NewColor", [Color] ),
        SELECTCOLUMNS ( Tab2, "NewColor", [Color] )
    ),
    [NewColor] = "Red"
)
3 Actions - Combined - Audits = UNION (
    SELECTCOLUMNS (
        'VenSafe - Actions',
        "ID", 'VenSafe - Actions'[ID],
        "Action", 'VenSafe - Actions'[Action],
        "Due Date", 'VenSafe - Actions'[Due Date],
        "DaysUntilDue", 'VenSafe - Actions'[DaysUntilDue],
        "OwnerName", 'VenSafe - Actions'[OwnerName],
        "ModuleId", 'VenSafe - Actions'[ModuleId],
        "ModulePrefix", 'VenSafe - Actions'[ModulePrefix],
        "Type", 'VenSafe - Actions'[Type],
        "ActionID", 'VenSafe - Actions'[ActionID],
        "Status", 'VenSafe - Actions'[Status],
        "CreatedByName", 'VenSafe - Actions'[CreatedByName],
        "CreatedDate", 'VenSafe - Actions'[CreatedDate],
        "UpdatedByName", 'VenSafe - Actions'[UpdatedByName],
        "Completed", 'VenSafe - Actions'[Completed],
        "CompletedByName", 'VenSafe - Actions'[CompletedByName],
        "FullDescription", 'VenSafe - Actions'[FullDescription],
        "UpdatedDate", 'VenSafe - Actions'[UpdatedDate],
        "CompletedDate", 'VenSafe - Actions'[CompletedDate],
        "Source","VenSafe"
    ),
    SELECTCOLUMNS (
        'BEAMS - All Actions',
        "ID", 'BEAMS - All Actions'[ID],
        "Action", 'BEAMS - All Actions'[Action],
        "Due Date", 'BEAMS - All Actions'[Date Due],
        "DaysUntilDue", "", 
        "OwnerName", 'BEAMS - All Actions'[Owner],
        "ModuleId", "", 
        "ModulePrefix", "", 
        "Type", 'BEAMS - All Actions'[Topic], 
        "ActionID", 'BEAMS - All Actions'[Action ID], 
        "Status", 'BEAMS - All Actions'[Status], 
        "CreatedByName", 'BEAMS - All Actions'[Assigned by], 
        "CreatedDate", BLANK(), 
        "UpdatedByName", "", 
        "Completed", "", 
        "CompletedByName", "", 
        "FullDescription", 'BEAMS - All Actions'[Description], 
        "UpdatedDate", "",
        "CompletedDate", 'BEAMS - All Actions'[Date Completed],
        "Source","Beams"
    )
 )
= Table.TransformColumnNames(#"Custom1", Text.Proper)
= Table.TransformColumnNames(#"Expanded Table Column1", each if Text.Contains(Text.Upper(_),"Old Text") then "New Text" & Text.Replace(Text.Upper(_),"Old Text","") else _)
Private Sub Worksheet_ChangeTimestamp(ByVal Target As Range)
'These need to be added into the worksheet VBA section itself
'Enter a name in column A and current date and time is entered automatically in column B. You can also copy a cell range and paste in column A. Empty cells are not processed.
Dim Value As Variant
If Not Intersect(Target, Range("A:A")) Is Nothing Then
    For Each Value In Target
        If Value <> "" Then
            Range("B" & Value.Row).Value = Now
        End If
    Next Value
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'These need to be added into the worksheet VBA section itself
'Enter a price in column B and a formula is instantly entered in column C.
' Formula in column c: Cell value in column B multiplied by 1.1

Dim lRow As Single
Dim AStr As String
Dim Value As Variant
If Not Intersect(Target, Range("B:B")) Is Nothing Then
    For Each Value In Target
        If Value <> "" Then
            Range("C" & Value.Row).Formula = "=" & Target.Address & "*1.1"
        End If
    Next Value
End If
End Sub
Sub SplitDocByHeading() 'Goes through the document and splits the document into new sections and names the word document files by heading type
Application.ScreenUpdating = False
Dim StrTmplt As String, StrPath As String, StrFlNm As String, Rng As Range, Doc As Document
With ActiveDocument
  StrTmplt = .AttachedTemplate.FullName
  StrPath = .Path & "\"
  With .Range
    With .Find   ' change these to search for specific formatting items
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Style = "Heading 2"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      Set Rng = .Paragraphs(1).Range.Duplicate
      With Rng
        StrFlNm = Replace(.Text, vbCr, "")
        Do
          If .Paragraphs.Last.Range.End = ActiveDocument.Range.End Then Exit Do
        Select Case .Paragraphs.Last.Next.Style
          Case "Heading 2" ' Update to set heading level
            Exit Do
          Case Else
            .MoveEnd wdParagraph, 1
          End Select
        Loop
      End With
      Set Doc = Documents.Add(Template:=StrTmplt, Visible:=False)
      With Doc
        .Range.FormattedText = Rng.FormattedText
        .SaveAs2 FileName:=StrPath & StrFlNm, Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False 'can change wdFormatXMLDocument to one of the types below
        .Close False
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Set Doc = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Sub fieldcodetotext_OriginalDocument() 'Option 2 - Convert the field codes to text in the original document
Dim MyString As String, FieldShowSetting As Boolean
For Each aField In ActiveDocument.Fields
aField.Select
MyString = MyString & vbCr & Selection.Fields(1).Code.Text ' Does not keeps the formating delination in place - i.e. no "}"
Next aField
Documents.Add
ActiveDocument.Content.InsertAfter MyString
End Sub
Sub fieldcodetotext_CreateNewDocument() 'OPtion 1 - Create a new Word document to save the converted field codes:
Dim MyString As String
ActiveWindow.View.ShowFieldCodes = True
For Each aField In ActiveDocument.Fields
aField.Select
MyString = "{ " & Selection.Fields(1).Code.Text & " }" ' Keeps the formating delination in place }  - i.e. keeps "}"
Selection.Text = MyString
Next aField
ActiveWindow.View.ShowFieldCodes = False
End Sub
Sub ConvertWordsToPdfs() 'Batch Convert Word Files To PDF, opens dialog to select folder and then goes about conversions
    Dim xIndex As String
    Dim xDlg As FileDialog
    Dim xFolder As Variant
    Dim xNewName As String
    Dim xFileName As String
    Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
    If xDlg.Show <> -1 Then Exit Sub
    xFolder = xDlg.SelectedItems(1) + "\"
    xFileName = Dir(xFolder & "*.*", vbNormal)
    While xFileName <> ""
        If ((Right(xFileName, 4)) <> ".doc" Or Right(xFileName, 4) <> ".docx") Then
            xIndex = InStr(xFileName, ".") + 1
            xNewName = Replace(xFileName, Mid(xFileName, xIndex), "pdf")
            Documents.Open FileName:=xFolder & xFileName, _
                ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
                PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                wdOpenFormatAuto, XMLTransform:=""
            ActiveDocument.ExportAsFixedFormat OutputFileName:=xFolder & xNewName, _
                ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
                wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
                Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
                CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
                BitmapMissingFonts:=True, UseISO19005_1:=False
            ActiveDocument.Close SaveChanges:=True
        End If
        xFileName = Dir()
    Wend
End Sub
Sub ZipAllEmailsInAFolder() 

    Dim objFolder As Outlook.Folder 

    Dim objItem As Object 

    Dim objMail As Outlook.MailItem 

    Dim strSubject As String 

    Dim varTempFolder As Variant 

    Dim varZipFile As Variant 

    Dim objShell As Object 

    Dim objFileSystem As Object 

    

    'Select an Outlook Folder 

    Set objFolder = Outlook.Application.Session.PickFolder 

  

    If Not (objFolder Is Nothing) Then 

       'Create a temp folder 

       varTempFolder = "C:\Users\cnewnham\Desktop\2\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS") 

       MkDir (varTempFolder) 

       varTempFolder = varTempFolder & "\" 

    

       'Save each email as msg file 

       For Each objItem In objFolder.Items 

  

           If TypeOf objItem Is MailItem Then 

              Set objMail = objItem 

              strSubject = objMail.subject 

              strSubject = Replace(strSubject, "/", " ") 

              strSubject = Replace(strSubject, "\", " ") 

              strSubject = Replace(strSubject, ":", "") 

              strSubject = Replace(strSubject, "?", " ") 

              strSubject = Replace(strSubject, Chr(34), " ") 

  

              objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG 

           End If 

       Next 

  

       'Create a new ZIP file 

       varZipFile = "C:\Users\cnewnham\Desktop\2\" & objFolder.Name & " Emails.zip" 

       Open varZipFile For Output As #1 

       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

       Close #1 

  

       'Add the exported msg files to the ZIP file 

       Set objShell = CreateObject("Shell.Application") 

       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

       On Error Resume Next 

       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

          Application.Wait (Now + TimeValue("0:00:01")) 

       Loop 

       On Error GoTo 0 

  

       'Delete the temp folder 

       Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

       objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1) 

    End If 

End Sub 
Public Sub UnzipFileInOutlook() 'Used to unzip files in an outlook message in the compose window or message received window 

    Dim objMail As Outlook.MailItem 

    Dim objAttachments As Outlook.Attachments 

    Dim objAttachment As Outlook.Attachment 

    Dim objShell As Object 

    Dim objFileSystem As Object 

    Dim strTempFolder As String 

    Dim strFilePath As String 

    Dim strFileName As String 

  

    Set objMail = Outlook.Application.ActiveInspector.CurrentItem 

    Set objAttachments = objMail.Attachments 

  

    'Save & Unzip the zip file in local drive 

    Set objShell = CreateObject("Shell.Application") 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    strTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp" & Format(Now, "yyyy-mm-dd-hh-mm-ss") 

    MkDir (strTempFolder) 

  

    For Each objAttachment In objAttachments 

        If Right(objAttachment.FileName, 3) = "zip" Then 

           strFilePath = strTempFolder & "\" & objAttachment.FileName 

           objAttachment.SaveAsFile (strFilePath) 

           objShell.NameSpace((strTempFolder)).CopyHere objShell.NameSpace((strFilePath)).Items 

        End If 

    Next 

  

    'Reattach the files extracted from the zip file 

    strFileName = Dir(strTempFolder & "\") 

  

    While Len(strFileName) > 0 

          objMail.Attachments.Add (strTempFolder & "\" & strFileName) 

          strFileName = Dir 

          objMail.Save 

    Wend 

  

    'Delete the attachments in “.zip” file extension 

    Set objAttachments = objMail.Attachments 

    For Each objAttachment In objAttachments 

        If Right(objAttachment.FileName, 3) = "zip" Then 

           objAttachment.Delete 

           objMail.Save 

        End If 

    Next 

  

    'Delete the temp folder and files 

    objFileSystem.DeleteFolder (strTempFolder) 

End Sub 
Sub ListSelectionMonth() 'Note need to create a new custom column Month before runnining this script 

    Dim aObj As Object 

    Dim oProp As Outlook.UserProperty 

    Dim sMonth 

      

    On Error Resume Next 

      

    For Each aObj In Application.ActiveExplorer.Selection 

        Set oMail = aObj 

          

        sMonth = Month(oMail.ReceivedTime) 

        Set oProp = oMail.UserProperties.Add("Month", olText, True) 

        oProp.Value = sMonth 

        oMail.Save 

          

        Err.Clear 

    Next 

      

End Sub 
Public Sub SaveMessagesAndAttachments() 

Dim objOL As Outlook.Application 

Dim objMsg As Outlook.MailItem 'Object 

Dim objAttachments As Outlook.Attachments 

Dim i As Long 

Dim lngCount As Long 

Dim StrFile As String 

Dim StrName As String 

Dim StrFolderPath As String 

Dim strPath As String 

Dim sFileType As String 

 

Dim FSO As Object 

Dim oldName 

Set FSO = CreateObject("Scripting.FileSystemObject") 

On Error Resume Next 

Set objOL = CreateObject("Outlook.Application") 

Set objMsg = objOL.ActiveExplorer.Selection.Item(1) 

StrName = objMsg.subject 

StrName = Left(StrName, 6) ' quoteID number is 6 characters. 

 

StrFolderPath = BrowseForFolder("C:\Users\cnewnham\Desktop\Output") 

StrFolderPath = StrFolderPath & "\" & StrName & "\" 

 

' create folder if doesn't exist 

If Not FSO.FolderExists(StrFolderPath) Then 

FSO.CreateFolder (StrFolderPath) 

End If 

 

' Save message as msg file type 

objMsg.SaveAs StrFolderPath & StrName & ".msg", olMSG 

 

'save any attachments 

Set objAttachments = objMsg.Attachments 

lngCount = objAttachments.Count 

 

If lngCount > 0 Then 

 

For i = lngCount To 1 Step -1 

 

StrFile = objAttachments.Item(i).FileName 

Debug.Print StrFile 

StrFile = StrFolderPath & StrFile 

objAttachments.Item(i).SaveAsFile StrFile 

 

Next i 

End If 

 

ExitSub: 

 

Set objAttachments = Nothing 

Set objMsg = Nothing 

Set objSelection = Nothing 

Set objOL = Nothing 

End Sub 
Sub ReplyWithAttachments() 'Reply with message attachments and as forward. 

    Dim oReply As Outlook.MailItem 

    Dim oItem As Object 

      

    Set oItem = GetCurrentItem() 

    If Not oItem Is Nothing Then 

        Set oReply = oItem.Reply 

        CopyAttachments oItem, oReply 

        oReply.Display 

        oItem.UnRead = False 

    End If 

      

    Set oReply = Nothing 

    Set oItem = Nothing 

End Sub 

  

Sub ReplyAllWithAttachments() 'Reply All with message attachments and as forward. 

    Dim oReply As Outlook.MailItem 

    Dim oItem As Object 

      

    Set oItem = GetCurrentItem() 

    If Not oItem Is Nothing Then 

        Set oReply = oItem.ReplyAll 

        CopyAttachments oItem, oReply 

        oReply.Display 

        oItem.UnRead = False 

    End If 

      

    Set oReply = Nothing 

    Set oItem = Nothing 

End Sub 

Function GetCurrentItem() As Object 

    Dim objApp As Outlook.Application 

          

    Set objApp = Application 

    On Error Resume Next 

    Select Case TypeName(objApp.ActiveWindow) 

        Case "Explorer" 

            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1) 

        Case "Inspector" 

            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem 

    End Select 

      

    Set objApp = Nothing 

End Function 

  

Sub CopyAttachments(objSourceItem, objTargetItem) 

   Set FSO = CreateObject("Scripting.FileSystemObject") 

   Set fldTemp = FSO.GetSpecialFolder(2) ' TemporaryFolder 

   strPath = fldTemp.Path & "\" 

   For Each objAtt In objSourceItem.Attachments 

      StrFile = strPath & objAtt.FileName 

      objAtt.SaveAsFile StrFile 

      objTargetItem.Attachments.Add StrFile, , , objAtt.DisplayName 

      FSO.DeleteFile StrFile 

   Next 

  

   Set fldTemp = Nothing 

   Set FSO = Nothing 

End Sub 
Sub AutoHighlight_AllOccurencesOfSpecificWords(objMail As Outlook.MailItem) 

    Dim strWord As String 

    Dim strHTMLBody As String 

  

    strHTMLBody = objMail.HTMLBody 

  

    'Change the word as per your wishes 

    strWord = "Pulse" 

  

    'If find the specific word 

    If InStr(strHTMLBody, strWord) > 0 Then 

       'Highlight it in yellow color 

       strHTMLBody = Replace(strHTMLBody, strWord, "<font style=" & Chr(34) & "background-color: yellow" & Chr(34) & ">" & strWord & "</font>") 

  

       objMail.HTMLBody = strHTMLBody 

    End If 

  

    'Add more words to be highlighted as per your needs 

    strWord = "Outlook" 

  

    If InStr(strHTMLBody, strWord) > 0 Then 

       strHTMLBody = Replace(strHTMLBody, strWord, "<font style=" & Chr(34) & "background-color: yellow" & Chr(34) & ">" & strWord & "</font>") 

  

       objMail.HTMLBody = strHTMLBody 

    End If 

  

    objMail.Save 

End Sub 

 

Sub HighlightString(MyMail As Outlook.MailItem) 

Dim strID As String 

Dim objMail As Outlook.MailItem 

strID = MyMail.EntryID 

Set objMail = Application.Session.GetItemFromID(strID) 

wordToSearch = "Pulse" 

' Ineed to find a way to match keyword from this line, assigned to wordToSearch 

 

If InStr(1, objMail.HTMLBody, wordToSearch, vbTextCompare) > 0 Then 

strData = objMail.HTMLBody 

strData = Replace(strData, wordToSearch, "<FONT style=" & Chr(34) & "BACKGROUND-COLOR: yellow" & Chr(34) & ">" & wordToSearch & "</FONT>") 

objMail.HTMLBody = strData 

objMail.Save 

End If 

Set objMail = Nothing 

End Sub 
Sub ForwardMultipleEmailsAsZipAttachment() 

    Dim objSelection As Outlook.Selection 

    Dim objMail As Outlook.MailItem 

    Dim strSubject As String 

    Dim strTempFolder As String 

    Dim varTempFolder As Variant 

    Dim objShell As Object 

    Dim varZipFile As Variant 

    Dim objForward As Outlook.MailItem 

  

    Set objSelection = Application.ActiveExplorer.Selection 

  

    If Not (objSelection Is Nothing) Then 

  

       'Save selected emails to Temporary folder 

       strTempFolder = CStr(Environ("USERPROFILE")) & "\AppData\Local\Temp" 

       varTempFolder = strTempFolder & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-") 

       MkDir (varTempFolder) 

       varTempFolder = varTempFolder & "\" 

 

       For Each objMail In objSelection 

  

           strSubject = objMail.subject 

  

           'Remove unsupported characters in the subject 

           strSubject = Replace(strSubject, "/", " ") 

           strSubject = Replace(strSubject, "\", " ") 

           strSubject = Replace(strSubject, ":", "") 

           strSubject = Replace(strSubject, "?", " ") 

           strSubject = Replace(strSubject, Chr(34), " ") 

  

           objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG 

       Next 

     

       'Create a new zip file 

       varZipFile = InputBox("Specify a name for the new zip file", "Name Zip File") 

       varZipFile = strTempFolder & "\" & varZipFile & ".zip" 

       Open varZipFile For Output As #1 

       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

       Close #1 

  

       'Copy all the saved emails to the new zip file 

       Set objShell = CreateObject("Shell.Application") 

       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

       'Keep macro running until compressing is done 

       On Error Resume Next 

       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

          Application.Wait (Now + TimeValue("0:00:01")) 

       Loop 

       On Error GoTo 0 

  

       Set objMail = Application.CreateItem(olMailItem) 

  

       'Add the zip attachment to a new email 

       With objMail 

            .Attachments.Add varZipFile 

            .Display 

       End With 

    End If 

End Sub 
Sub ProperCaseSubject() 

 

    Dim myMessage As Outlook.MailItem 

    Set myMessage = Outlook.ActiveInspector.CurrentItem 

 

    Dim subject As String 

 

    subject = myMessage.subject ' Problematic line 

                                ' You need to input this or capture this 

    s = StrConv(subject, vbProperCase) 

 

    myMessage.subject = s 

 

End Sub 
Option Explicit 

 

Public Sub ExportAttachments() 'Extract attachments from outlook folder accounting for duplicates 

    Dim objOL As Outlook.Application 

    Dim objMsg As Object 

    Dim objAttachments As Outlook.Attachments 

    Dim objSelection As Outlook.Selection 

    Dim i As Long, lngCount As Long 

    Dim filesRemoved As String, fName As String, StrFolder As String, saveFolder As String, savePath As String 

    Dim alterEmails As Boolean, overwrite As Boolean 

    Dim result 

     

    saveFolder = BrowseForFolder("Select the folder to save attachments to.") 

    If saveFolder = vbNullString Then Exit Sub 

     

    result = MsgBox("Do you want to remove attachments from selected file(s)? " & vbNewLine & _ 

    "(Clicking no will export attachments but leave the emails alone)", vbYesNo + vbQuestion) 

    alterEmails = (result = vbYes) 

     

    Set objOL = CreateObject("Outlook.Application") 

    Set objSelection = objOL.ActiveExplorer.Selection 

     

    For Each objMsg In objSelection 

        If objMsg.Class = olMail Then 

            Set objAttachments = objMsg.Attachments 

            lngCount = objAttachments.Count 

            If lngCount > 0 Then 

                filesRemoved = "" 

                For i = lngCount To 1 Step -1 

                    fName = objAttachments.Item(i).FileName 

                    savePath = saveFolder & "\" & fName 

                    overwrite = False 

                    While Dir(savePath) <> vbNullString And Not overwrite 

                        Dim newFName As String 

                        newFName = InputBox("The file '" & fName & _ 

                            "' already exists. Please enter a new file name, or just hit OK overwrite.", _ 

                            "Confirm File Name", fName) 

                        If newFName = vbNullString Then GoTo skipfile 

                        If newFName = fName Then overwrite = True Else fName = newFName 

                        savePath = saveFolder & "\" & fName 

                    Wend 

                     

                    objAttachments.Item(i).SaveAsFile savePath 

                     

                    If alterEmails Then 

                        filesRemoved = filesRemoved & "<br>""" & objAttachments.Item(i).FileName & """ (" & _ 

                                                                formatSize(objAttachments.Item(i).size) & ") " & _ 

                            "<a href=""" & savePath & """>[Location Saved]</a>" 

                        objAttachments.Item(i).Delete 

                    End If 

skipfile: 

                Next i 

                 

                If alterEmails Then 

                    filesRemoved = "<b>Attachments removed</b>: " & filesRemoved & "<br><br>" 

                     

                    Dim objDoc As Object 

                    Dim objInsp As Outlook.Inspector 

                    Set objInsp = objMsg.GetInspector 

                    Set objDoc = objInsp.WordEditor 

 

                    objMsg.HTMLBody = filesRemoved + objMsg.HTMLBody 

                    objMsg.Save 

                End If 

            End If 

        End If 

    Next 

     

ExitSub: 

    Set objAttachments = Nothing 

    Set objMsg = Nothing 

    Set objSelection = Nothing 

    Set objOL = Nothing 

End Sub 

 

Function formatSize(size As Long) As String 

    Dim val As Double, newVal As Double 

    Dim unit As String 

     

    val = size 

    unit = "bytes" 

     

    newVal = Round(val / 1024, 1) 

    If newVal > 0 Then 

        val = newVal 

        unit = "KB" 

    End If 

    newVal = Round(val / 1024, 1) 

    If newVal > 0 Then 

        val = newVal 

        unit = "MB" 

    End If 

    newVal = Round(val / 1024, 1) 

    If newVal > 0 Then 

        val = newVal 

        unit = "GB" 

    End If 

     

    formatSize = val & " " & unit 

End Function 

 

'Function purpose:  To Browser for a user selected folder. 

'If the "OpenAt" path is provided, open the browser at that directory 

'NOTE:  If invalid, it will open at the Desktop level 

Function BrowseForFolder(Optional Prompt As String, Optional OpenAt As Variant) As String 

    Dim ShellApp As Object 

    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt) 

 

    On Error Resume Next 

    BrowseForFolder = ShellApp.Self.Path 

    On Error GoTo 0 

    Set ShellApp = Nothing 

      

    'Check for invalid or non-entries and send to the Invalid error handler if found 

    'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid 

    Select Case Mid(BrowseForFolder, 2, 1) 

        Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 

        Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 

        Case Else: GoTo Invalid 

    End Select 

      

    Exit Function 

Invalid: 

     'If it was determined that the selection was invalid, set to False 

    BrowseForFolder = vbNullString 

End Function 

 

Function BrowseForFile(Optional Prompt As String, Optional OpenAt As Variant) As String 

    Dim ShellApp As Object 

    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 16 + 16384, OpenAt) 

     

    On Error Resume Next 

    BrowseForFile = ShellApp.Self.Path 

    On Error GoTo 0 

    Set ShellApp = Nothing 

      

    'Check for invalid or non-entries and send to the Invalid error handler if found 

    'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid 

    Select Case Mid(BrowseForFolder, 2, 1) 

        Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 

        Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 

        Case Else: GoTo Invalid 

    End Select 

      

    Exit Function 

Invalid: 

     'If it was determined that the selection was invalid, set to False 

    BrowseForFile = vbNullString 

End Function 

 

 
Dim strAttachmentFolder As String 

 

Sub ExtractAttachmentsFromEmailsStoredinWindowsFolder() 

    Dim objShell, objWindowsFolder As Object 

  

    'Select a Windows folder 

    Set objShell = CreateObject("Shell.Application") 

    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows Folder:", 0, "") 

  

    If Not objWindowsFolder Is Nothing Then 

       'Create a new folder for saving extracted attachments 

       strAttachmentFolder = "C:\Users\cnewnham\Downloads\attachments-" & Format(Now, "MMDDHHMMSS") & "\" 

       MkDir (strAttachmentFolder) 

       Call ProcessFolders(objWindowsFolder.Self.Path & "\") 

       MsgBox "Completed!", vbInformation + vbOKOnly 

    End If 

End Sub 

 

Sub ProcessFolders(StrFolderPath As String) 

    Dim objFileSystem As Object 

    Dim objFolder As Object 

    Dim objFiles As Object 

    Dim objFile As Object 

    Dim objItem As Object 

    Dim i As Long 

    Dim objSubfolder As Object 

 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    Set objFolder = objFileSystem.GetFolder(StrFolderPath) 

    Set objFiles = objFolder.Files 

  

    For Each objFile In objFiles 

        If objFileSystem.GetExtensionName(objFile) = "msg" Then 

           'Open the Outlook emails stored in Windows folder 

           Set objItem = Session.OpenSharedItem(objFile.Path) 

 

           If TypeName(objItem) = "MailItem" Then 

              If objItem.Attachments.Count > 0 Then 

                 'Extract attachments 

                 For i = objItem.Attachments.Count To 1 Step -1 

                     objItem.Attachments(i).SaveAsFile strAttachmentFolder & objItem.Attachments(i).FileName 

                 Next 

              End If 

           End If 

        End If 

    Next 

  

    'Process all subfolders recursively 

    If objFolder.SubFolders.Count > 0 Then 

       For Each objSubfolder In objFolder.SubFolders 

           If ((objSubfolder.Attributes And 2) = 0) And ((objSubfolder.Attributes And 4) = 0) Then 

              Call ProcessFolders(objSubfolder.Path) 

           End If 

       Next 

    End If 

End Sub 
Public Sub SaveMessagesAndAttachments() ' Export for Single Message 

Dim objOL As Outlook.Application 

Dim objMsg As Outlook.MailItem 'Object 

Dim objAttachments As Outlook.Attachments 

Dim i As Long 

Dim lngCount As Long 

Dim StrFile As String 

Dim StrName As String 

Dim StrFolderPath As String 

Dim strDeletedFiles As String 

 Dim sFileType As String 

Dim enviro As String 

enviro = CStr(Environ("USERPROFILE")) 

     

Dim FSO As Object 

Dim oldName 

     

Set FSO = CreateObject("Scripting.FileSystemObject") 

       

    On Error Resume Next 

Set objOL = CreateObject("Outlook.Application") 

Set objMsg = objOL.ActiveExplorer.Selection.Item(1) 

 StrName = StripIllegalChar(objMsg.subject) 

     

StrFolderPath = enviro & "\Documents\" & StrName & "\" 

If Not FSO.FolderExists(StrFolderPath) Then 

    FSO.CreateFolder (StrFolderPath) 

End If 

 

 objMsg.SaveAs StrFolderPath & StrName & ".htm", olHTML 

  

    Set objAttachments = objMsg.Attachments 

    lngCount = objAttachments.Count 

          

    If lngCount > 0 Then 

      

    For i = lngCount To 1 Step -1 

      

    StrFile = objAttachments.Item(i).FileName 

    Debug.Print StrFile 

    StrFile = StrFolderPath & StrFile 

    objAttachments.Item(i).SaveAsFile StrFile 

    

    Next i 

    End If 

           

ExitSub: 

  

Set objAttachments = Nothing 

Set objMsg = Nothing 

Set objSelection = Nothing 

Set objOL = Nothing 

End Sub 

 

Function StripIllegalChar(StrInput) 

    Dim RegX            As Object 

    Set RegX = CreateObject("vbscript.regexp") 

        

    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" 

    RegX.IgnoreCase = True 

    RegX.Global = True 

        

    StripIllegalChar = RegX.Replace(StrInput, "") 

        

ExitFunction: 

    Set RegX = Nothing 

        

End Function 
Dim strAttachmentFolder As String 

 

Sub ExtractAttachmentsFromEmailsStoredinWindowsFolder() 'Does not handle duplicates this one 

    Dim objShell, objWindowsFolder As Object 

  

    'Select a Windows folder 

    Set objShell = CreateObject("Shell.Application") 

    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows Folder:", 0, "") 

  

    If Not objWindowsFolder Is Nothing Then 

       'Create a new folder for saving extracted attachments 

       strAttachmentFolder = "C:\Users\cnewnham\Downloads\attachments-" & Format(Now, "MMDDHHMMSS") & "\" 

       MkDir (strAttachmentFolder) 

       Call ProcessFolders(objWindowsFolder.Self.Path & "\") 

       MsgBox "Completed!", vbInformation + vbOKOnly 

    End If 

End Sub 

 

Sub ProcessFolders(StrFolderPath As String) 

    Dim objFileSystem As Object 

    Dim objFolder As Object 

    Dim objFiles As Object 

    Dim objFile As Object 

    Dim objItem As Object 

    Dim i As Long 

    Dim objSubfolder As Object 

 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    Set objFolder = objFileSystem.GetFolder(StrFolderPath) 

    Set objFiles = objFolder.Files 

  

    For Each objFile In objFiles 

        If objFileSystem.GetExtensionName(objFile) = "msg" Then 

           'Open the Outlook emails stored in Windows folder 

           Set objItem = Session.OpenSharedItem(objFile.Path) 

 

           If TypeName(objItem) = "MailItem" Then 

              If objItem.Attachments.Count > 0 Then 

                 'Extract attachments 

                 For i = objItem.Attachments.Count To 1 Step -1 

                     objItem.Attachments(i).SaveAsFile strAttachmentFolder & objItem.Attachments(i).FileName 

                 Next 

              End If 

           End If 

        End If 

    Next 

  

    'Process all subfolders recursively 

    If objFolder.SubFolders.Count > 0 Then 

       For Each objSubfolder In objFolder.SubFolders 

           If ((objSubfolder.Attributes And 2) = 0) And ((objSubfolder.Attributes And 4) = 0) Then 

              Call ProcessFolders(objSubfolder.Path) 

           End If 

       Next 

    End If 

End Sub 
Option Explicit 

'*********************************************************************** 

'* Code based on sample code from Martin Green and adapted to my needs 

'* more on TheTechieGuy.com - Liron@TheTechieGuy.com 

'*********************************************************************** 

'*********************************************************************** 

 

Sub GetAttachments() 

On Error Resume Next 

'create the folder if it doesnt exists: 

    Dim FSO, ttxtfile, txtfile, WheretosaveFolder 

    Dim objFolders As Object 

    Set objFolders = CreateObject("WScript.Shell").SpecialFolders 

  

    'MsgBox objFolders("mydocuments") 

    ttxtfile = objFolders("mydocuments") 

     

    Set FSO = CreateObject("Scripting.FileSystemObject") 

    Set txtfile = FSO.CreateFolder(ttxtfile & "\Email Attachments") 

    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015 

    ' ------------------------------------------------------ 

        ' Set fso = Nothing 

    ' ------------------------------------------------------ 

    WheretosaveFolder = ttxtfile & "\Email Attachments" 

     

On Error GoTo GetAttachments_err 

' Declare variables 

    Dim ns As NameSpace 

    Dim Inbox As MAPIFolder 

    Dim Item As Object 

    Dim Atmt As Attachment 

    Dim FileName As String 

    Dim i As Integer 

    Set ns = GetNamespace("MAPI") 

    'Set Inbox = ns.GetDefaultFolder(olFolderInbox) 

    ' added the option to select whic folder to export 

    Set Inbox = ns.PickFolder 

     

    'to handle if the use cancalled folder selection 

    If Inbox Is Nothing Then 

                MsgBox "You need to select a folder in order to save the attachments", vbCritical, _ 

               "Export - Not Found" 

        Exit Sub 

    End If 

 

    '''' 

     

 

    i = 0 

' Check Inbox for messages and exit of none found 

    If Inbox.Items.Count = 0 Then 

        MsgBox "There are no messages in the selected folder.", vbInformation, _ 

               "Export - Not Found" 

        Exit Sub 

    End If 

' Check each message for attachments 

    For Each Item In Inbox.Items 

' Save any attachments found 

        For Each Atmt In Item.Attachments 

        ' This path must exist! Change folder name as necessary. 

         

        ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015 

        ' ------------------------------------------------------ 

            FileName = WheretosaveFolder & "\" & FSO.GetBaseName(Atmt.FileName) & i & "." & FSO.GetExtensionName(Atmt.FileName) 

        ' ------------------------------------------------------ 

            Atmt.SaveAsFile FileName 

            i = i + 1 

         Next Atmt 

    Next Item 

' Show summary message 

    If i > 0 Then 

        MsgBox "There were " & i & " attached files." _ 

        & vbCrLf & "These have been saved to the Email Attachments folder in My Documents." _ 

        & vbCrLf & vbCrLf & "Thank you for using Liron Segev - TheTechieGuy's utility", vbInformation, "Export Complete" 

    Else 

        MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found" 

    End If 

    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015 

    ' ------------------------------------------------------ 

        Set FSO = Nothing 

    ' ------------------------------------------------------ 

' Clear memory 

GetAttachments_exit: 

    Set Atmt = Nothing 

    Set Item = Nothing 

    Set ns = Nothing 

    Exit Sub 

' Handle errors 

GetAttachments_err: 

    MsgBox "An unexpected error has occurred." _ 

        & vbCrLf & "Please note and report the following information." _ 

        & vbCrLf & "Macro Name: GetAttachments" _ 

        & vbCrLf & "Error Number: " & Err.Number _ 

        & vbCrLf & "Error Description: " & Err.Description _ 

        , vbCritical, "Error!" 

    Resume GetAttachments_exit 

End Sub 
Dim xFSO As Scripting.FileSystemObject 

Sub CopyOutlookFldStructureToWinExplorer() 

    ExportAction "Copy" 

End Sub 

    

Sub ExportAction(xAction As String) 

Dim xFolder As Outlook.Folder 

Dim xFldPath As String 

xFldPath = SelectAFolder() 

If xFldPath = "" Then 

    MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook" 

Else 

    Set xFSO = New Scripting.FileSystemObject 

    Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder 

    ExportOutlookFolder xFolder, xFldPath 

End If 

Set xFolder = Nothing 

Set xFSO = Nothing 

End Sub 

  

Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String) 

Dim xSubFld As Outlook.Folder 

Dim xItem As Object 

Dim xPath As String 

Dim xFilePath As String 

Dim xSubject As String 

Dim xCount As Integer 

Dim xFilename As String 

On Error Resume Next 

xPath = xFldPath & "\" & OutlookFolder.Name 

'?????????,?????? 

If Dir(xPath, 16) = Empty Then MkDir xPath 

For Each xItem In OutlookFolder.Items 

    xSubject = ReplaceInvalidCharacters(xItem.subject) 

    xFilename = xSubject & ".msg" 

    xCount = 0 

    xFilePath = xPath & "\" & xFilename 

    If xFSO.FileExists(xFilePath) Then 

        xCount = xCount + 1 

        xFilename = xSubject & " (" & xCount & ").msg" 

        xFilePath = xPath & "\" & xFilename 

    End If 

    xItem.SaveAs xFilePath, olMSG 

Next 

For Each xSubFld In OutlookFolder.Folders 

    ExportOutlookFolder xSubFld, xPath 

Next 

Set OutlookFolder = Nothing 

Set xItem = Nothing 

End Sub 

  

Function SelectAFolder() As String 

Dim xSelFolder As Object 

Dim xShell As Object 

On Error Resume Next 

Set xShell = CreateObject("Shell.Application") 

Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0) 

If Not TypeName(xSelFolder) = "Nothing" Then 

    SelectAFolder = xSelFolder.Self.Path 

End If 

Set xSelFolder = Nothing 

Set xShell = Nothing 

End Function 

    

Function ReplaceInvalidCharacters(Str As String) As String 

Dim xRegEx 

Set xRegEx = CreateObject("vbscript.regexp") 

xRegEx.Global = True 

xRegEx.IgnoreCase = False 

xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?" 

ReplaceInvalidCharacters = xRegEx.Replace(Str, "") 

End Function 
Sub ConvertSelectedMailtoTask() 

    Dim objTask As Outlook.TaskItem 

    Dim objMail As Outlook.MailItem 

     

    Set objTask = Application.CreateItem(olTaskItem) 

    Set objMail = Application.ActiveExplorer.Selection.Item(1) 

 

With objTask 

    .subject = objMail.subject 

    .StartDate = objMail.ReceivedTime 

    .Body = objMail.Body 'Add the message as an attachment 

    .Attachments.Add objMail 

    .Save 

End With 

 

    Set objTask = Nothing 

    Set objMail = Nothing 

End Sub 
Sub ZipAllEmailsInAFolder() 

    Dim objFolder As Outlook.Folder 

    Dim objItem As Object 

    Dim objMail As Outlook.MailItem 

    Dim strSubject As String 

    Dim varTempFolder As Variant 

    Dim varZipFile As Variant 

    Dim objShell As Object 

    Dim objFileSystem As Object 

    

    'Select an Outlook Folder 

    Set objFolder = Outlook.Application.Session.PickFolder 

  

    If Not (objFolder Is Nothing) Then 

       'Create a temp folder 

       varTempFolder = "C:\Temp\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS") 

       MkDir (varTempFolder) 

       varTempFolder = varTempFolder & "\" 

    

       'Save each email as msg file 

       For Each objItem In objFolder.Items 

  

           If TypeOf objItem Is MailItem Then 

              Set objMail = objItem 

              strSubject = objMail.subject 

              strSubject = Replace(strSubject, "/", " ") 

              strSubject = Replace(strSubject, "\", " ") 

              strSubject = Replace(strSubject, ":", "") 

              strSubject = Replace(strSubject, "?", " ") 

              strSubject = Replace(strSubject, Chr(34), " ") 

  

              objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG 

           End If 

       Next 

  

       'Create a new ZIP file 

       varZipFile = "C:\Temp\" & objFolder.Name & " Emails.zip" 

       Open varZipFile For Output As #1 

       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

       Close #1 

  

       'Add the exported msg files to the ZIP file 

       Set objShell = CreateObject("Shell.Application") 

       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

       On Error Resume Next 

       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

          Application.Wait (Now + TimeValue("0:00:01")) 

       Loop 

       On Error GoTo 0 

  

       'Delete the temp folder 

       Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

       objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1) 

    End If 

End Sub 

 

 

 

 

 

 

Sub ZipAttachments() 

    Dim objMail As Outlook.MailItem 

    Dim objAttachments As Outlook.Attachments 

    Dim objAttachment As Outlook.Attachment 

    Dim objFileSystem As Object 

    Dim objShell As Object 

    Dim varTempFolder As Variant 

    Dim varZipFile As Variant 

  

    'Save the attachments to Temporary folder 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    varTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-") 

    MkDir (varTempFolder) 

    varTempFolder = varTempFolder & "\" 

  

    Set objMail = Outlook.Application.ActiveInspector.CurrentItem 

    Set objAttachments = objMail.Attachments 

    For Each objAttachment In objAttachments 

        objAttachment.SaveAsFile (varTempFolder & objAttachment.FileName) 

    Next 

  

    'Create a new zip file 

    varZipFile = InputBox("Specify a name for the new zip file", "Name Zip File", objMail.subject) 

    varZipFile = objFileSystem.GetSpecialFolder(2).Path & "\" & varZipFile & ".zip" 

    Open varZipFile For Output As #1 

    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

    Close #1 

  

    'Copy all the saved attachments to the new zip file 

     Set objShell = CreateObject("Shell.Application") 

     objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

     'Keep macro running until Compressing is done 

     On Error Resume Next 

     Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

        Application.Wait (Now + TimeValue("0:00:01")) 

     Loop 

     On Error GoTo 0 

  

     'Delete all the attachments 

     Set objAttachments = objMail.Attachments 

     While objAttachments.Count > 0 

           objAttachments.Item(1).Delete 

     Wend 

  

     'Add the new zip file to the current email 

     objMail.Attachments.Add varZipFile 

  

    'Prompt 

    MsgBox ("Complete!") 

End Sub 
Dim objDictionary As Object 

 

Sub CountSentMailsByMonth() 'Must enable Microsoft Excel Reference Library 

    Dim objOutlookFile As Outlook.Folder 

    Dim objFolder As Outlook.Folder 

    Dim objExcelApp As Excel.Aapplication 

    Dim objExcelWorkbook As Excel.Workbook 

    Dim objExcelWorksheet As Excel.Worksheet 

    Dim varMonths As Variant 

    Dim varItemCounts As Variant 

    Dim nLastRow As Integer 

  

    Set objDictionary = CreateObject("Scripting.Dictionary") 

    Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox) 

  

    'Get the default Outlook data file 

    Set objOutlookFile = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Parent 

  

    For Each objFolder In objOutlookFile.Folders 

        If objFolder.DefaultItemType = olMailItem Then 

           Call ProcessFolders(objFolder) 

        End If 

    Next 

 

    Set objExcelApp = CreateObject("Excel.Application") 

    objExcelApp.Visible = True 

    Set objExcelWorkbook = objExcelApp.Workbooks.Add 

    Set objExcelWorksheet = objExcelWorkbook.Sheets(1) 

  

    With objExcelWorksheet 

        .Cells(1, 1) = "Month" 

        .Cells(1, 2) = "Count" 

    End With 

  

    varMonths = objDictionary.Keys 

    varItemCounts = objDictionary.Items 

  

    For i = LBound(varMonths) To UBound(varMonths) 

        nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1 

        With objExcelWorksheet 

            .Cells(nLastRow, 1) = varMonths(i) 

            .Cells(nLastRow, 2) = varItemCounts(i) 

        End With 

    Next 

  

    objExcelWorksheet.Columns("A:B").AutoFit 

End Sub 

 

Sub ProcessFolders(ByVal objCurFolder As Outlook.Folder) 

    Dim i As Long 

    Dim objMail As Outlook.MailItem 

    Dim strMonth As String 

  

    For i = objCurFolder.Items.Count To 1 Step -1 

        If objCurFolder.Items(i).Class = olMail Then 

           Set objMail = objCurFolder.Items(i) 

           'Change to your own email address 

           If objMail.SenderEmailAddress = "you@datanumen.com" Then 

              strMonth = Format(Year(objMail.SentOn) & "-" & Month(objMail.SentOn), "YYYY/MM") 

  

              If objDictionary.Exists(strMonth) Then 

                 objDictionary(strMonth) = objDictionary(strMonth) + 1 

              Else 

                 objDictionary.Add strMonth, 1 

              End If 

           End If 

       End If 

    Next 

End Sub 
Sub ZipAllEmailsInAFolder()
    Dim objFolder As Outlook.Folder
    Dim objItem As Object
    Dim objMail As Outlook.MailItem
    Dim strSubject As String
    Dim varTempFolder As Variant
    Dim varZipFile As Variant
    Dim objShell As Object
    Dim objFileSystem As Object
   
    'Select an Outlook Folder
    Set objFolder = Outlook.Application.Session.PickFolder
 
    If Not (objFolder Is Nothing) Then
       'Create a temp folder
       varTempFolder = "C:\Temp\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS")
       MkDir (varTempFolder)
       varTempFolder = varTempFolder & "\"
   
       'Save each email as msg file
       For Each objItem In objFolder.Items
 
           If TypeOf objItem Is MailItem Then
              Set objMail = objItem
              strSubject = objMail.subject
              strSubject = Replace(strSubject, "/", " ")
              strSubject = Replace(strSubject, "\", " ")
              strSubject = Replace(strSubject, ":", "")
              strSubject = Replace(strSubject, "?", " ")
              strSubject = Replace(strSubject, Chr(34), " ")
 
              objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG
           End If
       Next
 
       'Create a new ZIP file
       varZipFile = "C:\Temp\" & objFolder.Name & " Emails.zip"
       Open varZipFile For Output As #1
       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
       Close #1
 
       'Add the exported msg files to the ZIP file
       Set objShell = CreateObject("Shell.Application")
       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items

       On Error Resume Next
       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count
          Application.Wait (Now + TimeValue("0:00:01"))
       Loop
       On Error GoTo 0
 
       'Delete the temp folder
       Set objFileSystem = CreateObject("Scripting.FileSystemObject")
       objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1)
    End If
End Sub






Sub ZipAttachments()
    Dim objMail As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Outlook.Attachment
    Dim objFileSystem As Object
    Dim objShell As Object
    Dim varTempFolder As Variant
    Dim varZipFile As Variant
 
    'Save the attachments to Temporary folder
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    varTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-")
    MkDir (varTempFolder)
    varTempFolder = varTempFolder & "\"
 
    Set objMail = Outlook.Application.ActiveInspector.CurrentItem
    Set objAttachments = objMail.Attachments
    For Each objAttachment In objAttachments
        objAttachment.SaveAsFile (varTempFolder & objAttachment.FileName)
    Next
 
    'Create a new zip file
    varZipFile = InputBox("Specify a name for the new zip file", "Name Zip File", objMail.subject)
    varZipFile = objFileSystem.GetSpecialFolder(2).Path & "\" & varZipFile & ".zip"
    Open varZipFile For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
 
    'Copy all the saved attachments to the new zip file
     Set objShell = CreateObject("Shell.Application")
     objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items

     'Keep macro running until Compressing is done
     On Error Resume Next
     Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count
        Application.Wait (Now + TimeValue("0:00:01"))
     Loop
     On Error GoTo 0
 
     'Delete all the attachments
     Set objAttachments = objMail.Attachments
     While objAttachments.Count > 0
           objAttachments.Item(1).Delete
     Wend
 
     'Add the new zip file to the current email
     objMail.Attachments.Add varZipFile
 
    'Prompt
    MsgBox ("Complete!")
End Sub

Sub display_all_chart_shapes()

    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            Debug.Print counter & "##" & sld.Name & " " & shp.Name
        Next shp
        counter = counter + 1
    Next sld

End Sub

Function pieknosc()
    
    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            'Debug.Print counter & "##" & sld.Name & " " & shp.Name
            '
            '
            ' KOMENTARZE
            '
            '
            If shp.Name = "TextBox 11" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 460
                shp.Width = 720
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 9
            End If
            '
            '
            ' PODTYTUŁY
            '
            '
            If shp.Name = "Podtytuł 2" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 10
                shp.Width = 900
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 24
            End If
            
            
            
        Next shp
        counter = counter + 1
    Next sld
End Function
Function Ping(strip)
Dim objshell, boolcode
Set objshell = CreateObject("Wscript.Shell")
boolcode = objshell.Run("ping -n 1 -w 1000 " & strip, 0, True)
If boolcode = 0 Then
    Ping = True
Else
    Ping = False
End If
End Function
Sub PingSystem()
Dim strip As String
Dim strPhoneNumber As String
Dim strMessage As String
Dim strPostData As String
Dim IE As Object

strPhoneNumber = Sheets("DATA").Cells(2, 1).Value

For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
    strip = ActiveSheet.Cells(introw, 2).Value
    If Ping(strip) = True Then
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Online"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 200, 0)
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Online"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"

        Set IE = Nothing
        
    Else
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(200, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Offline"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 6
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Offline"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"
        Set IE = Nothing
    End If
Next
End Sub
Sub PAUSE(Period As Single)
Dim TimeNow As Single
TimeNow = Timer
Do
    DoEvents
Loop While TimeNow + Period > Timer
End Sub
Sub ClearData()

Worksheets("Clients").Rows("2:" & Rows.Count).ClearContents
Worksheets("Cases").Rows("2:" & Rows.Count).ClearContents
Worksheets("Sessions").Rows("2:" & Rows.Count).ClearContents

End Sub
star

Tue Oct 05 2021 02:28:55 GMT+0000 (UTC) https://www.youtube.com/watch?v=uVr-VjBWS6M

#vba
star

Mon Sep 27 2021 07:18:02 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:07:26 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:05:58 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:05:38 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:05:17 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:04:53 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:04:35 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:04:16 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:03:58 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:03:24 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:03:04 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:02:35 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:02:18 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 06:01:28 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 05:53:51 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 05:19:36 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 05:04:22 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 05:03:43 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 05:03:11 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 04:58:25 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 04:54:28 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 04:50:38 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 04:38:51 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 04:26:33 GMT+0000 (UTC)

#vba
star

Wed Sep 08 2021 04:24:45 GMT+0000 (UTC) www.TheSpreadsheetGuru.com

#vba
star

Wed Sep 08 2021 04:24:08 GMT+0000 (UTC)

#vba
star

Thu Sep 02 2021 06:12:28 GMT+0000 (UTC) https://blog.enterprisedna.co/using-advanced-dax-for-multiple-if-statement-in-power-bi/

#vba
star

Thu Sep 02 2021 00:53:32 GMT+0000 (UTC) https://stackoverflow.com/questions/64374549/how-to-filter-table-after-dax-union-of-other-tables

#vba
star

Wed Aug 11 2021 03:09:04 GMT+0000 (UTC) https://social.technet.microsoft.com/Forums/en-US/395a9244-d5b4-47b5-92bb-3470fc2d61f4/transform-column-names-from-upper-to-proper?forum=powerquery

#vba
star

Wed Aug 11 2021 02:52:43 GMT+0000 (UTC) https://community.powerbi.com/t5/Desktop/Rename-column-headers-in-a-table/td-p/43801

#vba
star

Fri Aug 06 2021 07:02:46 GMT+0000 (UTC)

#vba
star

Fri Aug 06 2021 07:01:41 GMT+0000 (UTC)

#vba
star

Fri Aug 06 2021 07:01:21 GMT+0000 (UTC)

#vba
star

Fri Aug 06 2021 07:00:58 GMT+0000 (UTC)

#vba
star

Fri Aug 06 2021 06:59:52 GMT+0000 (UTC)

#vba
star

Fri Aug 06 2021 06:58:51 GMT+0000 (UTC)

#vba
star

Fri Aug 06 2021 06:57:14 GMT+0000 (UTC)

#vba
star

Thu Aug 05 2021 22:56:13 GMT+0000 (UTC)

#vba
star

Thu Aug 05 2021 22:39:26 GMT+0000 (UTC)

#vba
star

Thu Aug 05 2021 02:45:15 GMT+0000 (UTC)

#vba
star

Mon Jun 14 2021 13:49:22 GMT+0000 (UTC)

#vba
star

Tue Jun 08 2021 16:03:17 GMT+0000 (UTC)

#vba
star

Thu Mar 04 2021 15:24:04 GMT+0000 (UTC)

#vba
star

Fri Feb 26 2021 04:08:24 GMT+0000 (UTC)

#excel #vba

Save snippets that work with our extensions

Available in the Chrome Web Store Get Firefox Add-on Get VS Code extension