Remove password from MSWord Doc
Ignore formula Blank Cell results
Remove Modules
Delete worksheet without prompt or warning with VBA codee
ve and Close if idle for 2 minutesSave and Close if idle for 2 minutes
Unhide Sheets
ResetRange in Excel Sheet
3 options in an IF statement - one solution is INDEX statement
Auto E-mail / Email
Change TAB Order
Change Directory
Clear all unprotected cells
Clear unlocled cells (empty unlocked)
Confirm if folder exists, if not, ask to create it: #create folder
Copy / Paste values for entire sheet
Date Format
Day of the week
Delete button using a macro
Delete all blank rows
Delete duplicate items in a single list
Delete macro after execution
Delete excel Row based on value in an Array (Sensei Bchang)
End macro based on yes or no message box
Enter user name when opening a sheet / worksheet
Protect header & footer
Sub whatisthematrix()
Hide all blank rows in a cell range
Make sheet unhideable
Insert page break after the found word
Remove carriage returns
Reset Last cell for a sheet: #UsedRange
Save all files in an outlook folder
Protect or unprotect a sheet
=UNICHAR(10003) → insert checkmark in excel

Delete excel Row based on value in an Array

Sub delete_based_on_value()
          Dim Arr() As Variant
          Dim iTotElements As Integer
          Dim sCompareCol As String
          Dim iLastRow As Long
          Dim i As Long
          Dim j As Integer
          
    ' SET YOUR ARRAY VALUES HERE
          Arr = Array("9635",  "9610", "8735", "9036", "9408",  "9002", "9102", "9136", "9033",  "9133", "2992", "2993", "9028",  "9128", "9005", "9105", "8805",  "8905", "9405", "9305", "9007",  "9107", "8807", "8907", "9307",  "9407")
          ' SET THE TOTAL ELEMENTS IN THE ABOVE  ARRAY
          iTotElements = 26
          ' SET THE COLUMN THAT YOU WANT TO COMPARE
          sCompareCol = "C"
    iLastRow =  ActiveCell.SpecialCells(xlLastCell).Row
          
    For i = 1 To iLastRow
              ' LOOP THRU EACH  OF THE ARRAY TO COMPARE. ARRAY ELEMENTS STARTS WITH ZERO NOT ONE
              For j = 0 To  iTotElements - 1
                   ' COMPARE THE ARRAY DATA TO THE CURRENT CELL RANGE
                   If Arr(j) = Range(sCompareCol & i).Text Then
                       ' IF DATA MATCH, DELETE THE ROW
                       Rows(i & ":" & i).Select
                       Application.CutCopyMode = False
                       Selection.Delete Shift:=xlUp
                       ' BECAUSE WE DELETED A ROW, WE NEED TO READJUST "i" SO WE DO NOT SKIP  ANY ROWS
                       i = i - 1
                       ' BECAUSE WE DELETED A ROW, WE NEED TO READJUST iLastRow SO WE DO NOT LOOP THRU  EMPTY ROWS
                       iLastRow = iLastRow - 1
                   End If
              Next
          Next
          
    Range("A1").Select
    End Sub 

Remove password from MSWord Doc

Step 1. Save the document as an XML file

1. First, click on "File" and then find "Save As".
2. Navigate to "Save as type" and Select "Word XML Document (*.xml)" in the drop-down list. Then click the "Save" button and close MS Word.

Step 2. Open it with a TXT Editor and Type

1. Right-click on the saved XML file, select "Open with", and then choose "Notepad", "Word Pad", or Emacs, etc.
2. In Notepad, press "Ctrl + F" keys to search for enforcement.
3. Find w:enforcement = "1" and change it to w:enforcement = "0"
4. Find w:enforcement = "on" and change it to w:enforcement = "off"
5. Once you finish, click Save and then close it.

Step 3. Save the document as Word Doc again

1. Right-click on the .xml file and open it with "Microsoft Word"
2. Click "File" and "Save As", then go to Save as type and select "Word Document (*.docx)". Next, click "Save".

Ignore Formula Blank Cell Results
=IF(ISNUMBER(A1),A1, "")

'Remove Modules
Private Function remove()
Set vbCom = Application.VBE.ActiveVBProject.VBComponents
vbCom.remove VBComponent:= _
vbCom.Item("Module1")
vbCom.remove VBComponent:= _
vbCom.Item("Module2")
End Function

Delete worksheet without prompt or warning with VBA code
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True

Clear Clipboard
Application.CutCopyMode=False

Specify from starting Select cell(s) to last populated cell below them.
Sheets("Totals").Select
Range("A1:B1").Select
Range(Selection, Selection.End(xlDown)).Select

Activate Workbook, then save and close it.
Sub SavedAndClose()
Workbooks("workbookname.xlsm").Activate
ActiveWorkbook.Close Savechanges:=True
End Sub

Pause application to give time for processing
Application.Wait (Now + TimeValue("0:00:05"))

Save and Close if idle for 2 minutes:

1.) Click Insert > Module to create a Module script, and paste below code to it:

Dim CloseTime As Date
Sub TimeSetting()
CloseTime = Now + TimeValue("00:02:00")
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, _
Procedure:="SavedAndClose", Schedule:=True
End Sub
Sub TimeStop()
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, _
Procedure:="SavedAndClose", Schedule:=False
End Sub
Sub SavedAndClose()
'Activate Workbook
Workbooks("workbook_name.xlsm").Activate
ActiveWorkbook.Close Savechanges:=True
End Sub

2.) Then in the Project Explorer pane, double click This Workbook, and paste below code:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call TimeStop
End Sub

Private Sub Workbook_Open()
Call TimeSetting
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Call TimeStop
Call TimeSetting
End Sub

Unhide Sheets:

Sub UnprotectZ()

Sheet1.Visible = True
ThisWorkbook.Unprotect Password:="FRA"
Sheet2.Visible = True
ThisWorkbook.Unprotect Password:="FRA"
Sheet3.Visible = True
ThisWorkbook.Unprotect Password:="FRA"
Sheet4.Visible = True
ThisWorkbook.Unprotect Password:="FRA"

End Sub

ResetRange in Excel Sheet

ActiveSheet.UsedRange

3 options in an IF statement - one solution is INDEX statement

Solution for 3 options in an IF Statement:
==========================================

'Check if cell A4 = {MATCH array}, if match found, then {INDEX array}

=INDEX({"AA","BA","UA"},MATCH(A4,{"American Airlines","British Airways","United Airlines"},))

Auto E-mail / Email:

Sub pre_PackPost()
'Working in 2000-2010
'send the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim strName As String
Dim intExt As String
Dim strEmail As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strName = ActiveSheet.Range("O22")
intExt = ActiveSheet.Range("O23")
strEmail = ActiveSheet.Range("O24")
strID = Format(ActiveSheet.Range("H15"), "mm-dd-yy")

strbody = "Thank you," & Chr(13) & Chr(13) & Chr(13) & _
strName & vbNewLine & _
"LAX Export Department" & vbNewLine & _
" " & vbNewLine & _
"DHL GlobalMail" & vbNewLine & _
"921 W. Artesia Blvd." & vbNewLine & _
"Compton, CA 90220" & vbNewLine & _
"Phone: (562) 295-5700 ext " & intExt & vbNewLine & _
strEmail & vbNewLine & _
"www.dhlglobalmail.com" & vbNewLine & _
" " & vbNewLine & _
"Succeed with DHL Global Mail's unmatched solutions for" & vbNewLine & _
"one of the largest workshare partners of the U.S. Postal Service." & vbNewLine & _
" " & vbNewLine & _
"GOGREEN - Environmental Protection with DHL Global Mail" & vbNewLine & _
"Please consider your environmental responsibility before printing this E-Mail." & vbNewLine & _
" "

On Error Resume Next
With OutMail
.to = "kasia@packpost.co.uk; anjn@customsclearanceuk.com;info@customsclearanceuk.com; rudeeb@customsclearanceuk.com; dara@packpost.co.uk; james@packpost.co.uk; kam@packpost.co.uk; shaun@packpost.co.uk"
.CC = "Iadca; laxexport"
.BCC = ""
.Subject = "LAX = Pack Post = for " & strID
.Body = ActiveSheet.Range("N50") & Chr(13) & Chr(13) & Chr(13) & strbody
.Display '.Send
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
'Delete Macro after executing
'Just change the "Module1" to whatever module needs to be deleted..
With ThisWorkbook.VBProject.VBComponents
.Remove .Item("Module1")
End With
End Sub

Change TAB Order:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim aTabOrd As Variant
Dim i As Long

'Set the tab order of input cells
aTabOrd = Array("A5", "B5", "C5", "A10", "B10", "C10")

'Loop through the array of cell address
For i = LBound(aTabOrd) To UBound(aTabOrd)
'If the cell that's changed is in the array
If aTabOrd(i) = Target.Address(0, 0) Then
'If the cell that's changed is the last in the array
If i = UBound(aTabOrd) Then
'Select first cell in the array
Me.Range(aTabOrd(LBound(aTabOrd))).Select
Else
'Select next cell in the array
Me.Range(aTabOrd(i + 1)).Select
End If
End If
Next i

End Sub

How to use:

1. Copy the code above.
2. Open the workbook in which you want the code to work.
3. On the sheet for which you want to set the tab order, right-click the sheet tab and hit View Code.
This opens the Visual Basic Editor (VBE).
4. Paste the code into the code window that appears at right.
5. Edit the Array line in the code to suit your tab order.
6. Hit the Save diskette and close the VBE.
7. Save and close your Excel workbook.

Test the code:

1. Open the workbook.
2. Type into an unlocked cell and hit Tab or Enter.

Change Directory:

You must use ChDirNet, copy this at the top of your module

Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long

Sub ChDirNet(szPath As String)
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
If lReturn = 0 Then Err.Raise vbObjectError + 1, "Error setting path."
End Sub

Then use this in your macro

ChDirNet "\\ComputerName\YourFolder"

Clear all unprotected cells:

On Error Resume Next
ActiveSheet.UsedRange.Value = vbNullString
On Error GoTo 0

Clear unlocled cells (empty unlocked)

Sub emptyUnlocked()

ActiveSheet.Protect
On Error Resume Next
ActiveSheet.UsedRange = ""
On Error GoTo 0
ActiveSheet.Unprotect
ActiveSheet.Protect

End Sub

Confirm if folder exists, if not, ask to create it: #create folder

'==== I added this to confirm monthly directory exists before continuing ====
Dim rspCreate
If Dir("\\lax-fs\common\LAX CONSOLIDATIONS\Interpost\May 2013 Interpost\" & month & "\", vbDirectory) = "" Then
rspCreate = MsgBox("The " & month & " folder doesn't exist," & Chr(13) & "do you want me to create it?", vbYesNo)
If rspCreate = vbYes Then
MkDir ("\\lax-fs\common\LAX CONSOLIDATIONS\Interpost\May 2013 Interpost\" & month & "\")
Else: MsgBox ("You must have a " & month & " folder to continue.")
GoTo MyEnd
End If
End If
'==== I added this to confirm monthly directory exists before continuing ====

Copy / Paste values for entire sheet:

Sub ValuesOnly()
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
ws.UsedRange.Value = ws.UsedRange.Value
Next ws

End Sub

Date Format:
=============

'formulas to gather data:
=TEXT(MONTH(TODAY()),"00")
=DAY(TODAY())
=YEAR(TODAY())

'This will result in the current date (mmddyy)
=CONCATENATE(A1,A2,A3)

Day of the week:

Couple different ways to get Day of week based on date:

=========================
=CHOOSE(WEEKDAY(B6),"Sun","Mon","Tue","Wed","Thu","Fri","Sat")

=========================

=TEXT(A1,"ddd")

Assuming that the date in cell A1

=========================

Delete button using a macro:

ActiveSheet.Shapes("Button 3").Delete

Delete all blank rows:

Sub Macro1()
'******** DO THIS BEFORE APPLYING FILTER ***********
lMaxRow = Cells(Rows.Count, "A").End(xlUp).Row
' ********************************************

Cells.Select
Selection.AutoFilter Field:=1, Criteria1:="="
' Specify starting Row below: (Example: Rows("2:" & lMaxRow).Select)
Rows("10:" & lMaxRow).Select
Selection.Delete Shift:=xlUp

' Specify starting Range below: (Example: Range("B2").Select)
Range("B10").Select
End Sub

'**************Here is another version for a specific row**************
Sub Delete0s()
Dim i As Long
For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & i) = "" Then
Range("A" & i).Delete shift:=xlUp
End If
Next i
End Sub

Delete duplicate items in a single list:

Sample 1: Delete Duplicate Items in a Single List
The following sample macro searches a single list in the range A1:A65536 and deletes all duplicate items in the list. This macro requires that you do not have empty cells in the list range. If your list does contain empty cells, sort the data in ascending order so that the empty cells are all at the end of your list.

Sub DelDups_OneList()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

' Get count of records to search through.
iListCount = Sheets("Sheet1").Range("A1:A65536").Rows.Count
Sheets("Sheet1").Range("A1").Select
' Loop until end of records.
Do Until ActiveCell = ""
' Loop through records.
For iCtr = 1 To iListCount
' Don't compare against yourself.
' To specify a different column, change 1 to the column number.
If ActiveCell.Row <> Sheets("Sheet1").Cells(iCtr, 1).Row Then
' Do comparison of next record.
If ActiveCell.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet1").Cells(iCtr, 1).Delete xlShiftUp
' Increment counter to account for deleted row.
iCtr = iCtr + 1
End If
End If
Next iCtr
' Go to next record.
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Delete macro after execution:

Sub test()
With ThisWorkbook.VBProject.VBComponents
.Remove .Item("Module1")
End With
End Sub

End macro based on yes or no message box:

Sub preAlert()
''''''''''' Here Msgbox returns vbYes then move to block yes
If MsgBox("Is the Manifest completed?", vbYesNo, "Confirmation") = vbYes Then
MsgBox "Press OK to Save and Send the Pre-alert."
Else
'''''''''''''''' Here MsgBox returns vbNo then move to block no
MsgBox "Please finish the manifest" & Chr(13) & "before pressing the button."
GoTo MyEnd
End If
End Sub

''''''''''''' Put this at the end of the module
MyEnd:

Enter user name when opening a sheet / worksheet:

Enter username in a cell

Instruction:

1. Go to the Visual Basic Editor by pressing the keys Alt+F11.

2. From the Project Explorer, double-click over the ThisWorkbook object

3. That will execute an event window for you. At the top of the new code window, you will see the word 'General'. Select the drop down where you see general and select 'Workbook'.

4. You will notice that Excel VBA assumes the Open event. That means whatever code you insert in this procedure will execute automatically when the workbook is opened.

Private Sub Workbook_Open()
Range("B13").Value = Application.username
End Sub

Protect header & footer:

Private Sub Workbook_BeforePrint(Cancel As Boolean)
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "Compiled by: Emil de la Cruz"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
End Sub

Sub whatisthematrix()

Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer
On Error Resume Next
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126

ActiveSheet.Unprotect VBA.ChrW$(i) & VBA.ChrW$(j) & VBA.ChrW$(k) & _
VBA.ChrW$(l) & VBA.ChrW$(m) & VBA.ChrW$(i1) & VBA.ChrW$(i2) & VBA.ChrW$(i3) & _
VBA.ChrW$(i4) & VBA.ChrW$(i5) & VBA.ChrW$(i6) & VBA.ChrW$(n)
If ActiveSheet.ProtectContents = False Then
MsgBox "One usable password is " & VBA.ChrW$(i) & VBA.ChrW$(j) & _
VBA.ChrW$(k) & VBA.ChrW$(l) & VBA.ChrW$(m) & VBA.ChrW$(i1) & VBA.ChrW$(i2) & _
VBA.ChrW$(i3) & VBA.ChrW$(i4) & VBA.ChrW$(i5) & VBA.ChrW$(i6) & VBA.ChrW$(n)
ActiveWorkbook.Sheets(1).Select
Range("a1").FormulaR1C1 = VBA.ChrW$(i) & VBA.ChrW$(j) & _
VBA.ChrW$(k) & VBA.ChrW$(l) & VBA.ChrW$(m) & VBA.ChrW$(i1) & VBA.ChrW$(i2) & _
VBA.ChrW$(i3) & VBA.ChrW$(i4) & VBA.ChrW$(i5) & VBA.ChrW$(i6) & VBA.ChrW$(n)
Exit Sub
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next

End Sub

Hide all blank rows in a cell range:

Sub HideRows()
With Range("e28:e117")
.EntireRow.Hidden = False
For Each cell In Range("e28:e" & ActiveCell.SpecialCells(xlCellTypeLastCell).Row)
Select Case cell.Value
Case Is = 0
cell.EntireRow.Hidden = True
Case Is = ""
cell.EntireRow.Hidden = True
End Select
Next cell
End With
End Sub

Make sheet unhideable:

Sheets("Sheet1").Visible = xlVeryHidden

Insert page break after the found word:

Option Explicit
Sub milsPageBreaks()
Dim myRng As Range
Dim FoundCell As Range
Dim FirstAddress As String

With Worksheets("888")
.ResetAllPageBreaks 'remove them all to start
With .Range("a:a") 'what was selected??
Set FoundCell = .Find(What:="Compliments", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If FoundCell Is Nothing Then
'not found on the sheet
Else
FirstAddress = FoundCell.Address
Do
If FoundCell.Row > 1 Then
.Parent.HPageBreaks.Add Before:=FoundCell
End If
Set FoundCell = .FindNext(FoundCell)
Loop While Not FoundCell Is Nothing _
And FoundCell.Address <> FirstAddress
End If
End With
End With
End Sub

Remove carriage returns:

Sub RemoveCarriageReturns()
Dim MyRange As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For Each MyRange In ActiveSheet.UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
MyRange = Replace(MyRange, Chr(10), "")
End If
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Reset Last cell for a sheet: #UsedRange

Resulting Macro Example:
========================
Sub ResetRange()
ActiveSheet.UsedRange
End Sub

Save all files in an outlook folder:

Add the Macro to Outlook

Open Outlook and press alt-F8 on your keyboard. This will open your Macro window. Find and click the "Create" button to enter the macro code provided below:

'Attribute VB_Name = "Módulo1"

Option Explicit

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

Sub GuardarAdjuntos()
'Dim oApp As Application
'Dim oNS As NameSpace
'Dim oMsg As Object
'Dim oAttachments As Outlook.Attachments
'Dim strControl
'Set oApp = New Outlook.Application
'Set oNS = oApp.GetNamespace("MAPI")
'Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
Dim lpIDList As Long ' Declare Varibles
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
Dim strFolderTo, strSenderEmailFind, CurFolder, I, j, curItem, strSenderEmail, mypos, oAttachments, oattachment
szTitle = "BMW"
With tBrowseInfo
.hWndOwner = 0 ' Owner Form
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
'MsgBox sBuffer

'strSenderEmailFind = "nestor.castro@dhl.com"
Set CurFolder = Application.ActiveExplorer.CurrentFolder
For I = 1 To CurFolder.Items.Count
Set curItem = CurFolder.Items.Item(I)
'strSenderEmail = CurFolder.Items.Item(I).SenderEmailAddress
'mypos = InStr(1, strSenderEmailFind, strSenderEmail, 1)
'If mypos > 0 Then
Set oAttachments = curItem.Attachments
For j = 1 To oAttachments.Count
Set oattachment = oAttachments.Item(j)
oattachment.SaveAsFile sBuffer & "\" & oattachment.FileName
Next
' End If
Next
End If
End Sub

Protect or unprotect a sheet:

' The contents between quotes is the password.
' Example: ActiveSheet.Unprotect "password"

ActiveSheet.Unprotect ""
ActiveWorkbook.Unprotect ""

ActiveSheet.protect ""
ActiveWorkbook.protect ""