├── Functions └── GetHyperlink.vba ├── String Manipulation ├── Convert Text to Date.vba └── Create Comma Delimited Strings from Range.vba ├── Miscellaneous ├── Swap two ranges in Excel.vba ├── Create a dynamic index of worksheets.vba └── Collate and output all possible combinations.vba ├── Bulk Saving ├── Bulk Save Worksheets as CSV files.vba └── Bulk Save Worksheets as XLSX and Encrypt.vba ├── README.md └── Conditional Formatting └── Index_Colour_Scaler.vba /Functions/GetHyperlink.vba: -------------------------------------------------------------------------------- 1 | ' Returns the hyperlink from a text string that is hyperlinked 2 | Function GetHyperlink(rng As Range) As String 3 | If rng.Hyperlinks.Count > 0 Then 4 | GetHyperlink = rng.Hyperlinks(1).Address 5 | Else 6 | GetHyperlink = "" 7 | End If 8 | End Function 9 | -------------------------------------------------------------------------------- /String Manipulation/Convert Text to Date.vba: -------------------------------------------------------------------------------- 1 | Sub DateValueConverter() 2 | 3 | 'Note: Automatically takes selection as Input and replaces with Output 4 | 5 | Dim rng, cel As Range 6 | Set rng = Application.Selection 7 | For Each cel In rng 8 | cel.Value = DateValue(cel.Value) 9 | Next 10 | End Sub -------------------------------------------------------------------------------- /Miscellaneous/Swap two ranges in Excel.vba: -------------------------------------------------------------------------------- 1 | Sub SwapTwoRanges() 2 | ' This macro swaps the values from two selected ranges in Excel, without transferring the formatting. 3 | ' An InputBox will pop up twice to prompt you to enter the ranges. 4 | 5 | Dim Rng1 As Range, Rng2 As Range 6 | Dim arr1 As Variant, arr2 As Variant 7 | 8 | xTitleId = "Range Swapper" 9 | Set Rng1 = Application.Selection 10 | Set Rng1 = Application.InputBox("Range1:", xTitleId, Rng1.Address, Type:=8) 11 | Set Rng2 = Application.InputBox("Range2:", xTitleId, Type:=8) 12 | 13 | Application.ScreenUpdating = False 14 | arr1 = Rng1.Value 15 | arr2 = Rng2.Value 16 | Rng1.Value = arr2 17 | Rng2.Value = arr1 18 | Application.ScreenUpdating = True 19 | End Sub -------------------------------------------------------------------------------- /String Manipulation/Create Comma Delimited Strings from Range.vba: -------------------------------------------------------------------------------- 1 | Sub comma_delimited() 2 | 'Updated - Results now shows on debugging window instead 3 | Dim rng As Range 4 | Dim InputRng As Range, OutRng As Range 5 | Set InputRng = Application.Selection 6 | Set InputRng = Application.InputBox("Range :", "Source", Default:=InputRng.Address, Type:=8) 7 | 'Set OutRng = Application.InputBox("Out put to (single cell):", "Output cell", Type:=8) 8 | 'Set OutRng = ActiveSheet.Range("E2") 9 | outStr = "" 10 | For Each rng In InputRng 11 | If outStr = "" Then 12 | outStr = rng.Value 13 | Else 14 | outStr = outStr & ", " & rng.Value 15 | End If 16 | Next 17 | 'OutRng.Value = outStr 18 | Debug.Print outStr 19 | End Sub -------------------------------------------------------------------------------- /Bulk Saving/Bulk Save Worksheets as CSV files.vba: -------------------------------------------------------------------------------- 1 | Sub SaveWorksheetsAsCsv() 2 | 3 | ' This macro takes all the Worksheets within your active Workbook and saves it as separate files. 4 | ' Change parameters below to set export directory. 5 | 6 | Dim WS As Excel.Worksheet 7 | Dim SaveToDirectory As String 8 | Dim CurrentWorkbook As String 9 | Dim CurrentFormat As Long 10 | 11 | CurrentWorkbook = ThisWorkbook.FullName 12 | CurrentFormat = ThisWorkbook.FileFormat 13 | 14 | ' Update directory to save files 15 | ' Use backslashes (as opposed to Python or R) 16 | SaveToDirectory = "C:\test\" 17 | 18 | For Each WS In ThisWorkbook.Worksheets 19 | Sheets(WS.Name).Copy 20 | ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV 21 | ActiveWorkbook.Close savechanges:=False 22 | ThisWorkbook.Activate 23 | Next 24 | 25 | Application.DisplayAlerts = False 26 | ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat 27 | Application.DisplayAlerts = True 28 | ' Temporarily turn alerts off to prevent the user being prompted 29 | ' about overwriting the original file. 30 | 31 | End Sub -------------------------------------------------------------------------------- /Bulk Saving/Bulk Save Worksheets as XLSX and Encrypt.vba: -------------------------------------------------------------------------------- 1 | Sub SaveWorksheetsAsXLSX_And_Encrypt() 2 | 3 | 'This macro allows you to save all Worksheets in a Workbook as separate XLSX files 4 | 'The Password argument allows you to encrypt the Workbooks 5 | 6 | Dim WS As Excel.Worksheet 7 | Dim SaveToDirectory As String 8 | Dim CurrentWorkbook As String 9 | Dim CurrentFormat As Long 10 | CurrentWorkbook = ThisWorkbook.FullName 11 | CurrentFormat = ThisWorkbook.FileFormat 12 | 13 | ' Specify the Directory that you would like your XLSX files saved in 14 | ' The file names of the Workbooks is a function of the names of the Worksheets 15 | SaveToDirectory = "\folderA\subfolderA\" 16 | For Each WS In ThisWorkbook.Worksheets 17 | Sheets(WS.Name).Copy 18 | ActiveWorkbook.SaveAs Filename:=SaveToDirectory & "Data Analysis 2019" & "- " & WS.Name & ".xlsx", FileFormat:=51, _ 19 | Password:="D1FF1ULTP455W0RD" 20 | ActiveWorkbook.Close savechanges:=False 21 | ThisWorkbook.Activate 22 | Next 23 | Application.DisplayAlerts = False 24 | ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat 25 | Application.DisplayAlerts = True 26 | ' Temporarily turn alerts off to prevent the user being prompted 27 | ' about overwriting the original file. 28 | End Sub -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ExcelVBA 2 | Excel VBA Tools to make life a little less painful! 3 | 4 | This respository contains Excel VBA macros. In an age where the attention in Data Science is all in R and Python, it's perhaps odd to be writing Excel VBA macros. However, it is almost a truth universally acknowledged that you can never escape Excel - it is indeed the common language between end-consumers of data (stakeholders, audiences) and data analysts / scientists. Inevitably someone will always want to have something delivered in Excel. 5 | 6 | Since we cannot escape Excel (and arguably Excel is pretty great in ways), why not embrace it and make the experience more enjoyable? 7 | 8 | Whilst you are here, do also check out my other repository on PowerPoint VBA. 9 | 10 | --- 11 | 12 | ## How to run macros 13 | 14 | An example of the routine would be: 15 | 1. Run Alt + F11 or whichever way you prefer to start up the code editor and the module in Excel 16 | 2. Copy and paste the code in from the macro 17 | 3. Run 18 | 19 | The exception to the above would be custom _functions_, which would be become available as an Excel function once added to the code editor. 20 | 21 | --- 22 | 23 | ### Contact me 24 | 25 | Please feel free to submit suggestions and report bugs: 26 | -------------------------------------------------------------------------------- /Miscellaneous/Create a dynamic index of worksheets.vba: -------------------------------------------------------------------------------- 1 | Private Sub Dynamic_Index() 2 | 'INSTRUCTIONS TO CREATE A DYNAMIC INDEX OF WORKSHEETS 3 | 'You have to first insert a new sheet called 'Index'. 4 | 'Right click on the sheet to 'View Code' 5 | 'Run code as normal 6 | 'Adapted from ExtendOffice.com 7 | 'https://www.extendoffice.com/documents/excel/2653-excel-dynamic-list-of-worksheet-names.html 8 | 9 | Dim xSheet As Worksheet 10 | Dim xRow As Integer 11 | Dim calcState As Long 12 | Dim scrUpdateState As Long 13 | Application.ScreenUpdating = False 14 | xRow = 1 15 | With Me 16 | .Columns(1).ClearContents 17 | .Cells(1, 1) = "INDEX" 18 | .Cells(1, 1).Name = "Index" 19 | End With 20 | For Each xSheet In Application.Worksheets 21 | If xSheet.Name <> Me.Name Then 22 | xRow = xRow + 1 23 | With xSheet 24 | .Range("A1").Name = "Start_" & xSheet.Index 25 | .Hyperlinks.Add anchor:=.Range("A1"), Address:="", _ 26 | SubAddress:="Index", TextToDisplay:="Back to Index" 27 | End With 28 | Me.Hyperlinks.Add anchor:=Me.Cells(xRow, 1), Address:="", _ 29 | SubAddress:="Start_" & xSheet.Index, TextToDisplay:=xSheet.Name 30 | End If 31 | Next 32 | Application.ScreenUpdating = True 33 | End Sub 34 | -------------------------------------------------------------------------------- /Conditional Formatting/Index_Colour_Scaler.vba: -------------------------------------------------------------------------------- 1 | Sub Index_Scaler() 2 | Dim rng As Range 3 | 4 | ' Applies colour conditional formatting to indicate over and under indices 5 | 6 | Dim lowtier, midtier, hightier As Long 7 | ' Change values below to set "tier" paramters 8 | lowtier = 50 9 | midtier = 100 10 | hightier = 150 11 | 12 | Set rng = Selection 13 | rng.FormatConditions.AddColorScale ColorScaleType:=3 14 | rng.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority 15 | 16 | rng.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueNumber 17 | rng.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValueNumber 18 | rng.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueNumber 19 | rng.FormatConditions(1).ColorScaleCriteria(1).Value = lowtier 20 | rng.FormatConditions(1).ColorScaleCriteria(2).Value = midtier 21 | rng.FormatConditions(1).ColorScaleCriteria(3).Value = hightier 22 | 23 | With rng.FormatConditions(1).ColorScaleCriteria(1).FormatColor 24 | .Color = 7039480 25 | .TintAndShade = 0 26 | End With 27 | 28 | 29 | With rng.FormatConditions(1).ColorScaleCriteria(2).FormatColor 30 | .Color = 8711167 31 | .TintAndShade = 0 32 | End With 33 | 34 | With rng.FormatConditions(1).ColorScaleCriteria(3).FormatColor 35 | .Color = 8109667 36 | .TintAndShade = 0 37 | End With 38 | End Sub 39 | -------------------------------------------------------------------------------- /Miscellaneous/Collate and output all possible combinations.vba: -------------------------------------------------------------------------------- 1 | Sub Collate_and_output_all_combos() 2 | 'You will have a two-column data table (with headers) and as many rows as you want. 3 | 'It doesn't matter whether your data consists of text or number - no "calculation" is run directly on the values. 4 | 'You want to "multiply out" your data to get all possible combinations. 5 | 'Ordering: Column A for the variable to repeat multiple times (e.g. Alice, Alice, Alice, Bob, Bob, Bob) 6 | 'Ordering: Column B for the variable to display in sequence (e.g. 15, 20, 30, 15, 20, 30) 7 | 'Leave first row blank 8 | Dim wb As Workbook 9 | Dim ws As Worksheet 10 | Dim k, p, i As Integer 11 | Set wb = ActiveWorkbook 12 | Set ws = wb.ActiveSheet 13 | Application.ScreenUpdating = False 14 | 'The value 'k' is the total count of values in column A. 15 | 'The value 'p' is the total count of values in column B. 16 | 'The value 'i' shows the total number of combinations of your two variables - simple multiplification. 17 | k = ws.Application.CountA(Range("A:A")) 18 | p = ws.Application.CountA(Range("B:B")) 19 | i = k * p 20 | 'Prints these values on the header row of your first three columns. 21 | Range("A1").Value = k 22 | Range("B1").Value = p 23 | Range("C1").Value = i 24 | 'The commented column immediately below is an alternative method using formulas instead of VBA code - just ignore. 25 | 'Range("A1").Formula = "=COUNTA(A2:A9999)" 26 | 'Range("B1").Formula = "=COUNTA(B2:B9999)" 27 | 'Range("A1").Copy 28 | 'Range("A1").PasteSpecial (xlPasteValues) 29 | 'Range("B1").Copy 30 | 'Range("B1").PasteSpecial (xlPasteValues) 31 | 'Range("C1").Formula = "=A1*B1" 32 | 'i = Range("C1") 33 | 34 | 'The output would appear in Columns D and E. 35 | 'Please ensure you save your work first! 36 | 'Column references may be changed to suit your needs. 37 | Range("D:D").ClearContents 38 | Range("E:E").ClearContents 39 | Range("D1").Value = "Col1" 40 | Range("E1").Value = "Col2" 41 | Range("D2").Formula = "=INDIRECT(""A""&IF(MOD(ROW(A1),$B$1)=0,QUOTIENT(ROW(A1),$B$1)+1,QUOTIENT(ROW(A1),$B$1)+2))" 42 | Range("D2").Select 43 | Range("D2").Copy 44 | Range("D2").Resize(i, 1).PasteSpecial (xlPasteAll) 45 | Range("E2").Formula = "=IF(MOD(ROW(B1),$B$1)=0,INDIRECT(""B""&$B$1+1),INDIRECT(""B""&MOD(ROW(B1),$B$1)+1))" 46 | Range("E2").Select 47 | Range("E2").Copy 48 | Range("E2").Resize(i, 1).PasteSpecial (xlPasteAll) 49 | Range("A1").Select 50 | Application.ScreenUpdating = True 51 | MsgBox "All done mate." 52 | End Sub --------------------------------------------------------------------------------