VBA distance via Lat/Long

This code takes latitude and longitude of 2 locations and gets the distance in miles or kilometers, this is 'as the crow flies, not driving distance
I will try to edit when I find the calculations, but you can cut processing time dramatically (7 fold reduction if I recall) by subtracting lat 1 from lat 2 and long 1 from long 2, more than 1 is greater than 125 miles (will get exact numbers soon)

Place in a module to use as a function in a formula, or call directly via code
I got this online several years ago and unfortunately can't find the link and can't give credit
Private Const C_RADIUS_EARTH_KM As Double = 6370.97327862
Private Const C_RADIUS_EARTH_MI As Double = 3958.73926185

Private Const C_PI As Double = 3.14159265358979
Function GreatCircleDistance(Latitude1 As Double, Longitude1 As Double, _
Latitude2 As Double, Longitude2 As Double, _
ValuesAsDecimalDegrees As Boolean, _
ResultAsMiles As Boolean) As Double

Dim Lat1 As Double
Dim Lat2 As Double
Dim Long1 As Double
Dim Long2 As Double
Dim X As Long
Dim Delta As Double

If ValuesAsDecimalDegrees = True Then
X = 1
Else
X = 24
End If
' convert to decimal degrees

Lat1 = Latitude1 * X
Long1 = Longitude1 * X
Lat2 = Latitude2 * X
Long2 = Longitude2 * X

' convert to radians: radians = (degrees/180) * PI

Lat1 = (Lat1 / 180) * C_PI
Lat2 = (Lat2 / 180) * C_PI
Long1 = (Long1 / 180) * C_PI
Long2 = (Long2 / 180) * C_PI

' get the central spherical angle

Delta = ((2 * ArcSin(Sqr((Sin((Lat1 - Lat2) / 2) ^ 2) + _
Cos(Lat1) * Cos(Lat2) * (Sin((Long1 - Long2) / 2) ^ 2)))))

If ResultAsMiles = True Then

GreatCircleDistance = Delta * C_RADIUS_EARTH_MI

Else

GreatCircleDistance = Delta * C_RADIUS_EARTH_KM

End If
End Function
Function ArcSin(X As Double) As Double
' VBA doesn't have an ArcSin function. Improvise.
ArcSin = Atn(X / Sqr(-X * X + 1))
End Function

VBA multiple cells static reference

Credit http://www.ozgrid.com/forum/showthread.php?t=86661
'Select a range of sells and run, it will make all cell references static

Sub CycleAbsRel()

Dim inRange As Range, oneCell As Range
Static absRelMode As Long
absRelMode = (absRelMode Mod 4) + 1
Set inRange = Selection.SpecialCells(xlCellTypeFormulas)
If Not (inRange Is Nothing) Then
For Each oneCell In inRange
With oneCell
.FormulaR1C1 = Application.ConvertFormula(.FormulaR1C1, xlR1C1, xlR1C1, absRelMode, oneCell)
End With
Next oneCell
End If
End Sub

VBA: Random Letter generator

Private Sub MakeRandom()
Dim theNum As Double
Dim theUpper As String
Dim theLower As String

' Upper Case
theUpper = Chr(64 + Rnd() * 10000000 Mod 26)
' Lower Case
theLower = Chr(96 + Rnd() * 10000000 Mod 26)

End Sub

VBA: Manipulate registry *MAKE A BACKUP FIRST*

*Not responsible for those who mess up and didn't backup.

        Dim pRegKey As RegistryKey = Registry.CurrentUser
        pRegKey = pRegKey.OpenSubKey("Software\\Microsoft\\Internet Explorer\Main", True)
        'Dim val As Object = pRegKey.GetValue("Display Inline Images")
        pRegKey.SetValue("Display Inline Images", "no")

VBA: Extract all data from a closed workbook

Dim ConString As String
Dim strSQL    As String
Dim DBPATH    As String
Dim recordset As New ADODB.recordset

DBPATH = ThisWorkbook.Path & "\Data.xls"

ConString = "Provider=Microsoft.jet.oledb.4.0;" & _
                   "Data Source=" & DBPATH & ";" & _
                   "extended Properties=Excel 8.0;"

strSQL = "SELECT * FROM [Data$]"

Set recordset = New ADODB.recordset

On Error GoTo cleanup:

Call recordset.Open(strSQL, ConString, adOpenForwardOnly, adLockReadOnly,
CommandTypeEnum.adCmdText)

Call Sheets("DataDump").Range("A2").CopyFromRecordset(recordset)

Set recordset = Nothing

VBA: Find all files in folder by extension

Sub findBSAfiles()
 Dim objFSO    As Object
Dim objFolder As Object
Dim objFile   As Object
Dim strPath   As String
Dim strName   As String 
' Specify the folder...  
strPath = "pathname"
' Use Microsoft Scripting runtime.  
Set objFSO = CreateObject("Scripting.FileSystemObject")  
Set objFolder = objFSO.GetFolder(strPath)   
' Check extension of each file in folder.  
For Each objFile In objFolder.Files    
If Right(objFile.Name, 4) = ".xls" Then
strName = strName & "**" & objFile.Name & "**" & vbCrLf  
End If
Next objFile ' Display file names in message box. 
MsgBox strName  
Set objFSO = Nothing  
Set objFolder = Nothing  
Set objFile = Nothing
End Sub

VBA: Remove buttons by name

'If the forms menu, use
Sub RemoveButtons()     
Dim ShapeA As Button     
For Each ShapeA In ActiveSheet.Buttons           
If ShapeA.Caption = "Doodle" Then ShapeA.Delete     
Next ShapeA
End Sub

'If from the control toolbox, use
Sub RemoveButtons()     
Dim ShapeA As OLEObject     
For Each ShapeA In ActiveSheet.OLEObjects           
If ShapeA.Object.Caption = "Doodle" Then ShapeA.Delete     
Next ShapeA
End Sub

VBA: Get pressed key

This was Basically part of a code database dump, but it is the most searched for post on here, and looking at it I don't think it's as helpful as it could be.

So, at the bottom I will leave the code that was originally here, but I will add more meaningful code and descriptions first.

For information on the codes for various keys, in the VBA editor search help for 'OnKey'.

The following will set you workbook to intercept the keys control C and fire an event.

Note that for testing you will have to click run on the open event to set it up, or close and re-open the workbook.

'Add this to the ThisWorkbook Open event

Private Sub Workbook_Open()
Application.OnKey "^{c}", "Key_Pressed"
End Sub

'Add this to a new module

Sub Key_Pressed()
'Do What You Want
End Sub

That's it. If you want to pass variables to your event, whether it is the key that was pressed or a value or anything else, you pass it along as a parameter like this.

Private Sub Workbook_Open()
Application.OnKey "^{c}", "'Key_Pressed""C""'"
End Sub

Sub Key_Pressed(key)
MsgBox key & " key was Pressed"
End Sub

'----Old Code----

Declare Function GetKeyState Lib "user32" _(ByVal nVirtKey As Long) As Integer
Const VK_CONTROL As Integer = &H11  'Ctrl
Sub test()   
If GetKeyState(VK_CONTROL) < 0 Then
Ctrl = True
Else Ctrl = False   
If Ctrl = True Then       
MsgBox "pressed"   
Else       
MsgBox "Not"    End IfEnd Sub

'And this in the sheet module
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call test
End Sub

VBA: Open all workbooks inside a folder, run macro and save them

Sub LoopFolders()Dim oFSODim Folder As ObjectDim Files As ObjectDim file As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = oFSO.GetFolder("c:\MyTest")
For Each file In Folder.Files
If file.Type Like "*Microsoft Excel*" Then
Workbooks.Open Filename:=file.Path '<<<<< run macro here on Activeworkbook Activeworkbook.Close SaveChanges:=False
End If
Next file
Set oFSO = Nothing
End Sub