├── .gitignore ├── dummy.xlsx ├── dummy2.xlsx ├── dummy3.xlsx ├── Testing.xlsm ├── run-tests.sh ├── VBALib_VERSION.bas ├── README.md ├── update-version.sh ├── LICENSE ├── VBALib_MathFunctions.bas ├── VBALib_VBAUtils.bas ├── VBALib_StringUtils.bas ├── VBALib_ExcelLink.cls ├── VBALib_List.cls ├── VBALib_FormulaFunctions.bas ├── VBALib_FileUtils.bas ├── VBALib_ExcelTable.cls ├── VBALib_ArrayUtils.bas ├── VBALib_ExportImportSheets.bas └── VBALib_ExcelUtils.bas /.gitignore: -------------------------------------------------------------------------------- 1 | ~$* 2 | -------------------------------------------------------------------------------- /dummy.xlsx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nylen/vba-common-library/HEAD/dummy.xlsx -------------------------------------------------------------------------------- /dummy2.xlsx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nylen/vba-common-library/HEAD/dummy2.xlsx -------------------------------------------------------------------------------- /dummy3.xlsx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nylen/vba-common-library/HEAD/dummy3.xlsx -------------------------------------------------------------------------------- /Testing.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nylen/vba-common-library/HEAD/Testing.xlsm -------------------------------------------------------------------------------- /run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cd "$(dirname "$0")" 4 | 5 | ExcelSpreadsheetOps Testing.xlsm \ 6 | ImportAllModules . \ 7 | RunMacro RunTests 8 | -------------------------------------------------------------------------------- /VBALib_VERSION.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VBALib_VERSION" 2 | ' Common VBA Library, version 2014-06-16.1 3 | ' The other modules in this workbook whose names start with "VBALib_" provide 4 | ' commonly-used functions and types that are lacking in the VBA language. 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Common VBA library 2 | 3 | This library provides commonly-used functions and types that are lacking in the 4 | VBA macro language. Mainly intended for use with Excel. 5 | 6 | # Documentation 7 | 8 | The code contains extensive documentation. 9 | 10 | **TODO: Parse the docs out of the code** 11 | -------------------------------------------------------------------------------- /update-version.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | point="$1" 4 | 5 | [ -z "$point" ] && echo "Usage: $0 point-version-number" && exit 6 | 7 | cd "$(dirname "$0")" 8 | 9 | prefix="' Common VBA Library, version " 10 | version="`date +%Y-%m-%d`.$point" 11 | 12 | sed -i "s/^$prefix.*$/$prefix$version/" VBALib_VERSION.bas 13 | unix2dos VBALib_VERSION.bas 14 | echo Updated version to $version 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2012-2014+ James Nylen 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /VBALib_MathFunctions.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VBALib_MathFunctions" 2 | ' Common VBA Library - MathFunctions 3 | ' Provides useful mathematical functions. 4 | 5 | Option Explicit 6 | 7 | ' Returns the lesser of its two arguments. 8 | Public Function Min(a As Double, b As Double) As Double 9 | If a < b Then 10 | Min = a 11 | Else 12 | Min = b 13 | End If 14 | End Function 15 | 16 | ' Returns the greater of its two arguments. 17 | Public Function Max(a As Double, b As Double) As Double 18 | If a > b Then 19 | Max = a 20 | Else 21 | Max = b 22 | End If 23 | End Function 24 | 25 | ' Returns its argument truncated (rounded down) to the given significance or 26 | ' the given number of decimal places. 27 | ' @param significance: The significance, or step size, of the function. For 28 | ' example, a step size of 0.2 will ensure that the number returned is a 29 | ' multiple of 0.2. 30 | ' @param places: The number of decimal places to keep. 31 | Public Function Floor(num As Double, _ 32 | Optional significance As Double = 1, _ 33 | Optional places As Integer = 0) As Double 34 | 35 | ValidateFloorCeilingParams significance, places 36 | Floor = Int(num / significance) * significance 37 | End Function 38 | 39 | ' Returns its argument rounded up to the given significance or the given number 40 | ' of decimal places. 41 | ' @param significance: The significance, or step size, of the function. For 42 | ' example, a step size of 0.2 will ensure that the number returned is a 43 | ' multiple of 0.2. 44 | ' @param places: The number of decimal places to keep. 45 | Public Function Ceiling(num As Double, _ 46 | Optional significance As Double = 1, _ 47 | Optional places As Integer = 0) As Double 48 | 49 | ValidateFloorCeilingParams significance, places 50 | Ceiling = Floor(num, significance) 51 | If num <> Ceiling Then Ceiling = Ceiling + significance 52 | End Function 53 | 54 | Private Sub ValidateFloorCeilingParams( _ 55 | ByRef significance As Double, _ 56 | ByRef places As Integer) 57 | 58 | If places <> 0 Then 59 | If significance <> 1 Then 60 | Err.Raise 32000, Description:= _ 61 | "Pass either a number of decimal places or a significance " _ 62 | & "to Floor() or Ceiling(), not both." 63 | Else 64 | significance = 10 ^ -places 65 | End If 66 | End If 67 | End Sub 68 | -------------------------------------------------------------------------------- /VBALib_VBAUtils.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VBALib_VBAUtils" 2 | ' Common VBA Library - VBAUtils 3 | ' Provides useful functions for manipulating the VBA project object model. 4 | ' @reference Microsoft Visual Basic for Applications Extensibility 5.3 5 | ' (C:\Program Files\Common Files\Microsoft Shared\vba\VBA6\VBE6.DLL) 6 | 7 | Option Explicit 8 | 9 | ' Determines whether a VBA code module with a given name exists. 10 | ' @param wb: The workbook to check for the given module name (defaults to the 11 | ' active workbook). 12 | Public Function ModuleExists(moduleName As String, Optional wb As Workbook) _ 13 | As Boolean 14 | 15 | If wb Is Nothing Then Set wb = ActiveWorkbook 16 | Dim c As Variant ' VBComponent 17 | 18 | On Error GoTo notFound 19 | Set c = wb.VBProject.VBComponents.Item(moduleName) 20 | ModuleExists = True 21 | Exit Function 22 | 23 | notFound: 24 | ModuleExists = False 25 | End Function 26 | 27 | ' Removes the VBA code module with the given name. 28 | ' @param wb: The workbook to remove the module from (defaults to the active 29 | ' workbook). 30 | Public Sub RemoveModule(moduleName As String, Optional wb As Workbook) 31 | If wb Is Nothing Then Set wb = ActiveWorkbook 32 | If Not ModuleExists(moduleName, wb) Then 33 | Err.Raise 32000, Description:= _ 34 | "Module '" & moduleName & "' not found." 35 | End If 36 | Dim c As Variant ' VBComponent 37 | Set c = wb.VBProject.VBComponents.Item(moduleName) 38 | wb.VBProject.VBComponents.Remove c 39 | 40 | ' Sometimes the line above does not remove the module successfully. When 41 | ' this happens, c.Name does not return an error - otherwise it does. 42 | On Error GoTo nameError 43 | Dim n As String 44 | n = c.Name 45 | On Error GoTo 0 46 | Err.Raise 32000, Description:= _ 47 | "Failed to remove module '" & moduleName & "'. Try again later." 48 | 49 | nameError: 50 | ' Everything worked fine (the module was removed) 51 | End Sub 52 | 53 | ' Exports a VBA code module to a text file. 54 | ' @param wb: The workbook that contains the module to export (defaults to the 55 | ' active workbook). 56 | Public Sub ExportModule(moduleName As String, moduleFilename As String, _ 57 | Optional wb As Workbook) 58 | 59 | If wb Is Nothing Then Set wb = ActiveWorkbook 60 | If Not ModuleExists(moduleName, wb) Then 61 | Err.Raise 32000, Description:= _ 62 | "Module '" & moduleName & "' not found." 63 | End If 64 | wb.VBProject.VBComponents.Item(moduleName).Export moduleFilename 65 | End Sub 66 | 67 | ' Imports a VBA code module from a text file. 68 | ' @param wb: The workbook that will receive the imported module (defaults to 69 | ' the active workbook). 70 | Public Function ImportModule(moduleFilename As String, _ 71 | Optional wb As Workbook) As VBComponent 72 | 73 | If wb Is Nothing Then Set wb = ActiveWorkbook 74 | Set ImportModule = wb.VBProject.VBComponents.Import(moduleFilename) 75 | End Function 76 | -------------------------------------------------------------------------------- /VBALib_StringUtils.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VBALib_StringUtils" 2 | ' Common VBA Library - StringUtils 3 | ' Provides useful functions for manipulating strings. 4 | 5 | Option Explicit 6 | 7 | ' Determines whether a string starts with a given prefix. 8 | Public Function StartsWith(s As String, prefix As String, _ 9 | Optional caseSensitive As Boolean = True) As Boolean 10 | 11 | If caseSensitive Then 12 | StartsWith = (Left(s, Len(prefix)) = prefix) 13 | Else 14 | StartsWith = (Left(LCase(s), Len(prefix)) = LCase(prefix)) 15 | End If 16 | End Function 17 | 18 | ' Determines whether a string ends with a given suffix. 19 | Public Function EndsWith(s As String, suffix As String, _ 20 | Optional caseSensitive As Boolean = True) As Boolean 21 | 22 | If caseSensitive Then 23 | EndsWith = (Right(s, Len(suffix)) = suffix) 24 | Else 25 | EndsWith = (Right(LCase(s), Len(suffix)) = LCase(suffix)) 26 | End If 27 | End Function 28 | 29 | ' Splits a string on a given delimiter, trimming trailing and leading 30 | ' whitespace from each piece of the string. 31 | Public Function SplitTrim(s As String, delim As String) As String() 32 | Dim arr() As String 33 | arr = Split(s, delim) 34 | 35 | Dim i As Integer 36 | For i = 0 To UBound(arr) 37 | arr(i) = Trim(arr(i)) 38 | Next 39 | 40 | SplitTrim = arr 41 | End Function 42 | 43 | ' Trims a specified set of characters from the beginning and end 44 | ' of the given string. 45 | ' @param toTrim: The characters to trim. For example, if ",; " 46 | ' is given, then all spaces, commas, and semicolons will be removed 47 | ' from the beginning and end of the given string. 48 | Public Function TrimChars(s As String, toTrim As String) 49 | TrimChars = TrimTrailingChars(TrimLeadingChars(s, toTrim), toTrim) 50 | End Function 51 | 52 | ' Trims a specified set of characters from the beginning of the 53 | ' given string. 54 | ' @param toTrim: The characters to trim. For example, if ",; " 55 | ' is given, then all spaces, commas, and semicolons will be removed 56 | ' from the beginning of the given string. 57 | Public Function TrimLeadingChars(s As String, toTrim As String) 58 | If s = "" Then 59 | TrimLeadingChars = "" 60 | Exit Function 61 | End If 62 | Dim i As Integer 63 | i = 1 64 | While InStr(toTrim, Mid(s, i, 1)) > 0 And i <= Len(s) 65 | i = i + 1 66 | Wend 67 | TrimLeadingChars = Mid(s, i) 68 | End Function 69 | 70 | ' Trims a specified set of characters from the end of the given 71 | ' string. 72 | ' @param toTrim: The characters to trim. For example, if ",; " 73 | ' is given, then all spaces, commas, and semicolons will be removed 74 | ' from the end of the given string. 75 | Public Function TrimTrailingChars(s As String, toTrim As String) 76 | If s = "" Then 77 | TrimTrailingChars = "" 78 | Exit Function 79 | End If 80 | Dim i As Integer 81 | i = Len(s) 82 | While InStr(toTrim, Mid(s, i, 1)) > 0 And i >= 1 83 | i = i - 1 84 | Wend 85 | TrimTrailingChars = Left(s, i) 86 | End Function 87 | -------------------------------------------------------------------------------- /VBALib_ExcelLink.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "VBALib_ExcelLink" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Common VBA Library - VBALib_ExcelLink 11 | ' This is an object that represents and manipulates a link from one Excel 12 | ' workbook to another. 13 | 14 | Option Explicit 15 | 16 | Private mWorkbook As Workbook 17 | Private mName As String 18 | 19 | ' Returns the name of this Excel link. 20 | Public Property Get Name() As String 21 | Name = mName 22 | End Property 23 | 24 | ' Returns the current status of this Excel link. The possible values can be 25 | ' found here: https://office.microsoft.com/en-us/excel-help/HV080555653.aspx 26 | Public Property Get Status() As XlLinkStatus 27 | Status = mWorkbook.LinkInfo(mName, xlLinkInfoStatus) 28 | End Property 29 | 30 | ' Initializes the link object with the necessary parameters. INTERNAL ONLY - 31 | ' Do not call this method from user code. 32 | Public Sub Initialize(wb As Workbook, linkName As String) 33 | mName = linkName 34 | Set mWorkbook = wb 35 | End Sub 36 | 37 | ' Updates the values for this link from the source spreadsheet. 38 | Public Sub UpdateValues() 39 | If Status <> xlLinkStatusSourceOpen Then 40 | mWorkbook.UpdateLink mName, xlLinkTypeExcelLinks 41 | End If 42 | End Sub 43 | 44 | ' Breaks this link, replacing the formulas that linked to the source 45 | ' spreadsheet with their values. Sometimes Excel prevents breaking links 46 | ' completely, if there are named ranges left behind from the original 47 | ' workbook. This function will remove these named ranges and attempt to 48 | ' break the link again if it still exists. Returns whether the link was 49 | ' successfully broken. 50 | ' @param errorIfFail: Whether to throw an error if breaking the link fails. 51 | ' Deafults to True. 52 | Public Function Break(Optional errorIfFail As Boolean = True) As Boolean 53 | mWorkbook.BreakLink mName, xlLinkTypeExcelLinks 54 | 55 | Dim wbNameStr As String 56 | wbNameStr = "[" & Replace(GetFilename(mName), "'", "''") & "]" 57 | 58 | Dim n As Name 59 | For Each n In mWorkbook.Names 60 | If InStr(1, n.RefersTo, wbNameStr, vbTextCompare) > 0 Then 61 | n.Delete 62 | End If 63 | Next 64 | 65 | Break = True 66 | 67 | If ExcelLinkExists(mName, mWorkbook) Then 68 | mWorkbook.BreakLink mName, xlLinkTypeExcelLinks 69 | If ExcelLinkExists(mName, mWorkbook) Then 70 | If errorIfFail Then 71 | Err.Raise 32000, Description:= _ 72 | "Failed to break Excel link to workbook '" & mName & "'." 73 | Else 74 | Break = False 75 | End If 76 | End If 77 | End If 78 | End Function 79 | 80 | ' Changes this link to point to another Excel workbook. 81 | Public Sub ChangeSource(newWorkbookPath As String) 82 | mWorkbook.ChangeLink mName, newWorkbookPath, xlLinkTypeExcelLinks 83 | If ExcelLinkExists(newWorkbookPath) Then 84 | mName = GetExcelLink(newWorkbookPath).Name 85 | Else 86 | mName = newWorkbookPath 87 | End If 88 | End Sub 89 | 90 | ' Opens the Excel workbook referenced by this link. 91 | Public Function OpenSource() As Workbook 92 | mWorkbook.OpenLinks mName, Type:=xlLinkTypeExcelLinks 93 | End Function 94 | -------------------------------------------------------------------------------- /VBALib_List.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "VBALib_List" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Common VBA Library - VBALib_List 11 | ' This is a dynamic array that expands efficiently. 12 | 13 | Option Explicit 14 | 15 | Private Const LOWER_BOUND = 1 16 | Private Const RESIZE_FACTOR = 1.75 17 | 18 | Private mCount As Integer 19 | 20 | Private mItems() As Variant 21 | 22 | ' Gets the number of items in the list. 23 | Public Property Get Count() As Integer 24 | Count = mCount 25 | End Property 26 | 27 | ' Sets the item at the given index to the given value. 28 | Public Property Let Item(i As Integer, val As Variant) 29 | CheckIndex i 30 | If IsObject(val) Then 31 | Set mItems(i) = val 32 | Else 33 | mItems(i) = val 34 | End If 35 | End Property 36 | 37 | ' Gets the item at the given index. 38 | Public Property Get Item(i As Integer) As Variant 39 | CheckIndex i 40 | If IsObject(mItems(i)) Then 41 | Set Item = mItems(i) 42 | Else 43 | Item = mItems(i) 44 | End If 45 | End Property 46 | 47 | ' Gets all list items as an array, or an empty array if the list does not 48 | ' contain any items. 49 | Public Property Get Items() As Variant() 50 | If mCount = 0 Then 51 | ' Return an empty array. This is the only way I know of to create 52 | ' an empty array in VBA. It's kind of wonky because the resulting 53 | ' array has LBound = 0 and UBound = -1. 54 | Items = Array() 55 | Else 56 | Dim arr() As Variant 57 | ReDim arr(LOWER_BOUND To LOWER_BOUND + mCount - 1) 58 | 59 | Dim i As Integer 60 | For i = LOWER_BOUND To LOWER_BOUND + mCount - 1 61 | If IsObject(mItems(i)) Then 62 | Set arr(i) = mItems(i) 63 | Else 64 | arr(i) = mItems(i) 65 | End If 66 | Next 67 | 68 | ' TODO: Doesn't this copy the array (so it's copied twice)? 69 | Items = arr 70 | End If 71 | End Property 72 | 73 | Private Sub CheckIndex(i As Integer) 74 | If i < LOWER_BOUND Then 75 | Err.Raise 32000, Description:= _ 76 | "VBALib_List item index is less than lower bound." 77 | End If 78 | 79 | If i > mCount Then 80 | Err.Raise 32000, Description:= _ 81 | "VBALib_List item index is greater than upper bound." 82 | End If 83 | End Sub 84 | 85 | ' Removes all items from the list. 86 | Public Sub Clear() 87 | ReDim mItems(LOWER_BOUND - 1 To LOWER_BOUND) 88 | mCount = 0 89 | End Sub 90 | 91 | ' Adds a value to the end of the list. 92 | Public Sub Add(val As Variant) 93 | Resize mCount + 1 94 | If IsObject(val) Then 95 | Set mItems(LOWER_BOUND + mCount - 1) = val 96 | Else 97 | mItems(LOWER_BOUND + mCount - 1) = val 98 | End If 99 | End Sub 100 | 101 | ' Adds a value to the end of the list, if the list does not already 102 | ' contain that value. 103 | Public Sub AddOnce(val As Variant) 104 | If Not Contains(val) Then Add val 105 | End Sub 106 | 107 | ' Adds a range of items to the end of the list. 108 | Public Sub AddRange(val As Variant) 109 | Dim v As Variant 110 | For Each v In val 111 | Add v 112 | Next 113 | End Sub 114 | 115 | ' Adds a range of items to the end of the list, only adding the items 116 | ' that are not already contained in the list. 117 | Public Sub AddRangeOnce(val As Variant) 118 | Dim v As Variant 119 | For Each v In val 120 | AddOnce v 121 | Next 122 | End Sub 123 | 124 | ' Determines whether the list contains a given item. 125 | Public Function Contains(val As Variant) As Boolean 126 | Contains = False 127 | Dim i As Integer 128 | For i = LOWER_BOUND To LOWER_BOUND + mCount - 1 129 | If mItems(i) = val Then 130 | Contains = True 131 | Exit For 132 | End If 133 | Next 134 | End Function 135 | 136 | Private Sub Resize(newCount As Integer) 137 | If newCount > UBound(mItems) - LOWER_BOUND + 1 Then 138 | ReDim Preserve mItems(LOWER_BOUND - 1 _ 139 | To Int(UBound(mItems) * RESIZE_FACTOR + 0.5)) 140 | End If 141 | mCount = newCount 142 | End Sub 143 | 144 | Private Sub Class_Initialize() 145 | Clear 146 | End Sub 147 | -------------------------------------------------------------------------------- /VBALib_FormulaFunctions.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VBALib_FormulaFunctions" 2 | ' Common VBA Library - FormulaFunctions 3 | ' Provides functions that are useful in Excel formulas. 4 | 5 | Option Explicit 6 | 7 | ' Retrieves the given element of an array. 8 | Public Function ArrayElement(arr As Variant, i1 As Variant, _ 9 | Optional i2 As Variant, Optional i3 As Variant, _ 10 | Optional i4 As Variant, Optional i5 As Variant) As Variant 11 | 12 | If IsMissing(i2) Then 13 | If IsObject(arr(i1)) Then 14 | Set ArrayElement = arr(i1) 15 | Else 16 | ArrayElement = arr(i1) 17 | End If 18 | ElseIf IsMissing(i3) Then 19 | If IsObject(arr(i1, i2)) Then 20 | Set ArrayElement = arr(i1, i2) 21 | Else 22 | ArrayElement = arr(i1, i2) 23 | End If 24 | ElseIf IsMissing(i4) Then 25 | If IsObject(arr(i1, i2, i3)) Then 26 | Set ArrayElement = arr(i1, i2, i3) 27 | Else 28 | ArrayElement = arr(i1, i2, i3) 29 | End If 30 | ElseIf IsMissing(i5) Then 31 | If IsObject(arr(i1, i2, i3, i4)) Then 32 | Set ArrayElement = arr(i1, i2, i3, i4) 33 | Else 34 | ArrayElement = arr(i1, i2, i3, i4) 35 | End If 36 | Else 37 | If IsObject(arr(i1, i2, i3, i4, i5)) Then 38 | Set ArrayElement = arr(i1, i2, i3, i4, i5) 39 | Else 40 | ArrayElement = arr(i1, i2, i3, i4, i5) 41 | End If 42 | End If 43 | End Function 44 | 45 | ' Splits a string into an array, optionally limiting the number 46 | ' of items in the returned array. 47 | Public Function StringSplit(s As String, delim As String, _ 48 | Optional limit As Long = -1) As String() 49 | 50 | StringSplit = Split(s, delim, limit) 51 | End Function 52 | 53 | ' Joins an array into a string by inserting the given delimiter in between 54 | ' items. 55 | Public Function StringJoin(arr() As Variant, delim As String) As String 56 | StringJoin = Join(arr, delim) 57 | End Function 58 | 59 | ' Returns a newline (vbLf) character for use in formulas. 60 | Public Function NewLine() As String 61 | NewLine = vbLf 62 | End Function 63 | 64 | ' Returns an array suitable for using in an array formula. When this 65 | ' function is called from an array formula, it will detect whether or 66 | ' not the array should be transposed to fit into the range. 67 | Public Function GetArrayForFormula(arr As Variant) As Variant 68 | If IsObject(Application.Caller) Then 69 | Dim len1 As Long, len2 As Long 70 | Select Case ArrayRank(arr) 71 | Case 0 72 | GetArrayForFormula = Empty 73 | Exit Function 74 | Case 1 75 | len1 = ArrayLen(arr) 76 | len2 = 1 77 | Case 2 78 | len1 = ArrayLen(arr) 79 | len2 = ArrayLen(arr, 2) 80 | Case Else 81 | Err.Raise 32000, Description:= _ 82 | "Invalid number of dimensions (" & ArrayRank(arr) _ 83 | & "; expected 1 or 2)." 84 | End Select 85 | 86 | If Application.Caller.Rows.Count > Application.Caller.Columns.Count _ 87 | And len1 > len2 Then 88 | 89 | GetArrayForFormula = WorksheetFunction.Transpose(arr) 90 | Else 91 | GetArrayForFormula = arr 92 | End If 93 | Else 94 | GetArrayForFormula = arr 95 | End If 96 | End Function 97 | 98 | ' Converts a range to a normalized array. 99 | Public Function RangeToArray(r As Range) As Variant() 100 | If r.Cells.Count = 1 Then 101 | RangeToArray = Array(r.Value) 102 | ElseIf r.Rows.Count = 1 Or r.Columns.Count = 1 Then 103 | RangeToArray = NormalizeArray(r.Value) 104 | Else 105 | RangeToArray = r.Value 106 | End If 107 | End Function 108 | 109 | ' Returns the width of a column on a sheet. If the column number is 110 | ' not given and this function is used in a formula, then it returns 111 | ' the column width of the cell containing the formula. 112 | Public Function ColumnWidth(Optional c As Integer = 0) As Variant 113 | Application.Volatile 114 | Dim s As Worksheet 115 | If IsObject(Application.Caller) Then 116 | Set s = Application.Caller.Worksheet 117 | Else 118 | Set s = ActiveSheet 119 | End If 120 | If c <= 0 And IsObject(Application.Caller) Then 121 | c = Application.Caller.Column 122 | End If 123 | ColumnWidth = s.Columns(c).Width 124 | End Function 125 | 126 | ' Returns the height of a row on a sheet. If the row number is 127 | ' not given and this function is used in a formula, then it returns 128 | ' the row height of the cell containing the formula. 129 | Public Function RowHeight(Optional r As Integer = 0) As Variant 130 | Application.Volatile 131 | Dim s As Worksheet 132 | If IsObject(Application.Caller) Then 133 | Set s = Application.Caller.Worksheet 134 | Else 135 | Set s = ActiveSheet 136 | End If 137 | If r <= 0 And IsObject(Application.Caller) Then 138 | r = Application.Caller.Row 139 | End If 140 | RowHeight = s.Rows(r).Height 141 | End Function 142 | 143 | ' Returns the formula of the given cell or range, optionally in R1C1 style. 144 | Public Function GetFormula(r As Range, Optional r1c1 As Boolean = False) _ 145 | As Variant 146 | 147 | If r1c1 Then 148 | GetFormula = r.FormulaR1C1 149 | Else 150 | GetFormula = r.Formula 151 | End If 152 | End Function 153 | -------------------------------------------------------------------------------- /VBALib_FileUtils.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VBALib_FileUtils" 2 | ' Common VBA Library - FileUtils 3 | ' Provides useful functions for working with filenames and paths. 4 | 5 | Option Explicit 6 | 7 | Private Declare Function GetTempPathA Lib "kernel32" _ 8 | (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long 9 | 10 | ' Determines whether a file with the given name exists. 11 | ' @param findFolders: If true, the function will return true if a folder 12 | ' with the given name exists. 13 | Public Function FileExists(ByVal testFilename As String, _ 14 | Optional findFolders As Boolean = False) As Boolean 15 | 16 | ' Include read-only files, hidden files, system files. 17 | Dim attrs As Long 18 | attrs = (vbReadOnly Or vbHidden Or vbSystem) 19 | 20 | If findFolders Then 21 | attrs = (attrs Or vbDirectory) ' Include folders as well. 22 | End If 23 | 24 | 'If Dir() returns something, the file exists. 25 | FileExists = False 26 | On Error Resume Next 27 | FileExists = (Dir(TrimTrailingChars(testFilename, "/\"), attrs) <> "") 28 | End Function 29 | 30 | ' Determines whether a folder with the given name exists. 31 | Public Function FolderExists(folderName As String) As Boolean 32 | On Error Resume Next 33 | FolderExists = ((GetAttr(folderName) And vbDirectory) = vbDirectory) 34 | End Function 35 | 36 | ' Creates the given directory, including any missing parent folders. 37 | Public Sub MkDirRecursive(folderName As String) 38 | MkDirRecursiveInternal folderName, folderName 39 | End Sub 40 | 41 | Private Sub MkDirRecursiveInternal(folderName As String, _ 42 | originalFolderName As String) 43 | 44 | If folderName = "" Then 45 | ' Too many recursive calls to this function (GetDirectoryName will 46 | ' eventually return an empty string) 47 | Err.Raise 32000, _ 48 | Description:="Failed to create folder: " & originalFolderName 49 | End If 50 | 51 | Dim parentFolderName As String 52 | parentFolderName = GetDirectoryName(folderName) 53 | If Not FolderExists(parentFolderName) Then 54 | MkDirRecursiveInternal parentFolderName, originalFolderName 55 | End If 56 | 57 | If Not FolderExists(folderName) Then 58 | MkDir folderName 59 | End If 60 | End Sub 61 | 62 | ' Merges two path components into a single path. 63 | Public Function CombinePaths(p1 As String, p2 As String) As String 64 | CombinePaths = _ 65 | TrimTrailingChars(p1, "/\") & "\" & _ 66 | TrimLeadingChars(p2, "/\") 67 | End Function 68 | 69 | ' Fixes slashes within a path: 70 | ' - Converts all forward slashes to backslashes 71 | ' - Removes multiple consecutive slashes (except for UNC paths) 72 | ' - Removes any trailing slashes 73 | Public Function NormalizePath(ByVal p As String) As String 74 | Dim isUNC As Boolean 75 | isUNC = StartsWith(p, "\\") 76 | p = Replace(p, "/", "\") 77 | While InStr(p, "\\") > 0 78 | p = Replace(p, "\\", "\") 79 | Wend 80 | If isUNC Then p = "\" & p 81 | NormalizePath = TrimTrailingChars(p, "\") 82 | End Function 83 | 84 | ' Returns the folder name of a path (removes the last component 85 | ' of the path). 86 | Public Function GetDirectoryName(ByVal p As String) As String 87 | p = NormalizePath(p) 88 | Dim i As Integer 89 | i = InStrRev(p, "\") 90 | If i = 0 Then 91 | GetDirectoryName = "" 92 | Else 93 | GetDirectoryName = Left(p, i - 1) 94 | End If 95 | End Function 96 | 97 | ' Returns the filename of a path (the last component of the path). 98 | Public Function GetFilename(ByVal p As String) As String 99 | p = NormalizePath(p) 100 | Dim i As Integer 101 | i = InStrRev(p, "\") 102 | GetFilename = Mid(p, i + 1) 103 | End Function 104 | 105 | ' Returns the extension of a filename (including the dot). 106 | Public Function GetFileExtension(ByVal p As String) As String 107 | Dim i As Integer 108 | i = InStrRev(p, ".") 109 | If i > 0 Then 110 | GetFileExtension = Mid(p, i) 111 | Else 112 | GetFileExtension = "" 113 | End If 114 | End Function 115 | 116 | Private Function ListFiles_Internal(filePattern As String, attrs As Long) _ 117 | As Variant() 118 | 119 | Dim filesList As New VBALib_List 120 | Dim folderName As String 121 | 122 | If FolderExists(filePattern) Then 123 | filePattern = NormalizePath(filePattern) & "\" 124 | folderName = filePattern 125 | Else 126 | folderName = GetDirectoryName(filePattern) & "\" 127 | End If 128 | 129 | Dim currFilename As String 130 | currFilename = Dir(filePattern, attrs) 131 | 132 | While currFilename <> "" 133 | If (attrs And vbDirectory) = vbDirectory Then 134 | If FolderExists(folderName & currFilename) _ 135 | And currFilename <> "." And currFilename <> ".." Then 136 | 137 | filesList.Add folderName & currFilename 138 | End If 139 | Else 140 | filesList.Add folderName & currFilename 141 | End If 142 | currFilename = Dir 143 | Wend 144 | 145 | ListFiles_Internal = filesList.Items 146 | End Function 147 | 148 | ' Lists all files matching the given pattern. 149 | ' @param filePattern: A directory name, or a path with wildcards: 150 | ' - C:\Path\to\Folder 151 | ' - C:\Path\to\Folder\ExcelFiles.xl* 152 | Public Function ListFiles(filePattern As String) As Variant() 153 | ListFiles = ListFiles_Internal(filePattern, _ 154 | vbReadOnly Or vbHidden Or vbSystem) 155 | End Function 156 | 157 | ' Lists all folders matching the given pattern. 158 | ' @param folderPattern: A directory name, or a path with wildcards: 159 | ' - C:\Path\to\Folder 160 | ' - C:\Path\to\Folder\OtherFolder_* 161 | Public Function ListFolders(folderPattern As String) As Variant() 162 | ListFolders = ListFiles_Internal(folderPattern, _ 163 | vbReadOnly Or vbHidden Or vbSystem Or vbDirectory) 164 | End Function 165 | 166 | ' Returns the path to a folder that can be used to store temporary 167 | ' files. 168 | Public Function GetTempPath() As String 169 | Const MAX_PATH = 256 170 | 171 | Dim folderName As String 172 | Dim ret As Long 173 | 174 | folderName = String(MAX_PATH, 0) 175 | ret = GetTempPathA(MAX_PATH, folderName) 176 | 177 | If ret <> 0 Then 178 | GetTempPath = Left(folderName, InStr(folderName, Chr(0)) - 1) 179 | Else 180 | Err.Raise 32000, Description:= _ 181 | "Error getting temporary folder." 182 | End If 183 | End Function 184 | -------------------------------------------------------------------------------- /VBALib_ExcelTable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "VBALib_ExcelTable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Common VBA Library - VBALib_ExcelTable 11 | ' This is an object that represents and manipulates a table in an Excel 12 | ' workbook. 13 | 14 | Option Explicit 15 | 16 | Private mListObject As ListObject 17 | 18 | ' Returns the name of this Excel table. 19 | Public Property Get Name() As String 20 | Name = mListObject.Name 21 | End Property 22 | 23 | ' Returns the number of data rows in this Excel table, not including the 24 | ' header, total, or Insert rows. 25 | Public Property Get DataRowCount() As Long 26 | DataRowCount = mListObject.ListRows.Count 27 | End Property 28 | 29 | ' Returns the underlying object for this Excel table (a ListObject). 30 | Public Property Get ListObject() As ListObject 31 | Set ListObject = mListObject 32 | End Property 33 | 34 | ' Returns the value of the given cell in this Excel table. 35 | Public Property Get CellValue(r As Long, c As Variant) As Variant 36 | CellValue = ColumnRange(c).Cells(r).Value 37 | End Property 38 | 39 | ' Sets the value of the given cell in this Excel table. 40 | Public Property Let CellValue(r As Long, c As Variant, val As Variant) 41 | ColumnRange(c).Cells(r).Value = val 42 | End Property 43 | 44 | ' Returns the ListColumn object for the given column of this Excel table. 45 | Private Property Get Column(c As Variant) As ListColumn 46 | On Error GoTo badColumn 47 | Set Column = mListObject.ListColumns(c) 48 | Exit Property 49 | 50 | badColumn: 51 | On Error GoTo 0 52 | Err.Raise 32000, Description:= _ 53 | "Table '" & Name & "' does not contain a column '" & c & "'." 54 | End Property 55 | 56 | ' Returns the data range for the given column of this Excel table. 57 | Public Property Get ColumnRange(c As Variant) As Range 58 | Dim listCol As ListColumn 59 | Set listCol = Column(c) 60 | 61 | On Error GoTo noDataRange 62 | Set ColumnRange = listCol.DataBodyRange 63 | Exit Property 64 | 65 | noDataRange: 66 | On Error GoTo 0 67 | Err.Raise 32000, Description:= _ 68 | "Failed to get data range for column '" & c & "' of table '" _ 69 | & Name & "'." 70 | End Property 71 | 72 | ' Initializes the table object with the necessary parameters. INTERNAL ONLY - 73 | ' Do not call this method from user code. 74 | Public Sub Initialize(listObj As ListObject) 75 | Set mListObject = listObj 76 | End Sub 77 | 78 | ' Resizes this Excel table to the given number of data rows. 79 | Public Sub Resize(numRows As Long) 80 | Dim oldNumRows As Long 81 | oldNumRows = DataRowCount 82 | 83 | ' Don't allow tables to be resized to zero rows. Excel won't really do 84 | ' this anyway - it's possible to get the DataBodyRange to be empty, in 85 | ' which case the single row displayed in the table is the Insert row, but 86 | ' this creates more problems than it solves. Instead, resize the table to 87 | ' one row, and set a flag to clear out any remaining data later. 88 | Dim clearTable As Boolean 89 | If numRows = 0 Then 90 | numRows = 1 91 | clearTable = True 92 | Else 93 | clearTable = False 94 | End If 95 | 96 | ' Resize the table (add 1 to the number of rows because mListObject.Range 97 | ' includes the header row). 98 | mListObject.Resize _ 99 | mListObject.Range.Resize( _ 100 | numRows + 1, _ 101 | mListObject.ListColumns.Count) 102 | 103 | ' If the table is resized to have one row, but the row contains no data, 104 | ' the row will be treated as the Insert row, and the data row count will 105 | ' remain zero. This will cause problems since the table doesn't actually 106 | ' have a DataBodyRange. To avoid this situation, put a space in the first 107 | ' column, which will cause the Insert row to change to a data row. After 108 | ' setting the value once, it can be removed and the row will remain part 109 | ' of the DataBodyRange. 110 | If numRows = 1 And DataRowCount = 0 Then 111 | mListObject.Range.Cells(1, 1).Offset(1, 0).Value = " " 112 | mListObject.DataBodyRange.ClearContents 113 | End If 114 | 115 | ' The user requested that the table be resized to zero rows. We resized 116 | ' it down to one row, now clear out the data. 117 | If clearTable Then 118 | mListObject.DataBodyRange.ClearContents 119 | ClearSort 120 | End If 121 | 122 | ' If the new number of rows is less than the old number of rows, clear out 123 | ' the rows that were just removed from the table. 124 | If numRows < oldNumRows Then 125 | mListObject.DataBodyRange _ 126 | .Offset(numRows, 0) _ 127 | .Resize(oldNumRows - numRows, mListObject.ListColumns.Count) _ 128 | .ClearContents 129 | End If 130 | End Sub 131 | 132 | ' Clears this Excel table and resizes it to one row. 133 | Public Sub Clear() 134 | Resize 0 135 | End Sub 136 | 137 | ' Returns the values of this table as an array, optionally limited to a subset 138 | ' of the table's columns. 139 | ' @param startColumn: The index or name of the first column in the table to 140 | ' return the values for (defaults to 1). 141 | ' @param endColumn: The index or name of the last column in the table to 142 | ' return the values for (defaults to the last column in the table). 143 | Public Function GetValues( _ 144 | Optional startColumn As Variant = 1, _ 145 | Optional endColumn As Variant = Empty) _ 146 | As Variant() 147 | 148 | startColumn = Column(startColumn).Index 149 | If IsEmpty(endColumn) Then 150 | endColumn = mListObject.ListColumns.Count 151 | Else 152 | endColumn = Column(endColumn).Index 153 | End If 154 | 155 | GetValues = mListObject.DataBodyRange _ 156 | .Resize(ColumnSize:=endColumn - startColumn + 1) _ 157 | .Offset(ColumnOffset:=startColumn - 1) _ 158 | .Value 159 | End Function 160 | 161 | ' Sets the values of this table from an array, optionally resizing the table 162 | ' if the number of rows in the array does not match the number of rows in the 163 | ' table. 164 | ' @param resizeTable: Whether to resize the table to match the number of 165 | ' elements in the first dimension of the given array (defaults to True). 166 | ' @param startColumn: The index or name of the first column in the table that 167 | ' should receive values from the given array (defaults to 1). 168 | Public Sub SetValues(arr() As Variant, _ 169 | Optional resizeTable As Boolean = True, _ 170 | Optional startColumn As Variant = 1) 171 | 172 | If resizeTable Then 173 | Resize ArrayLen(arr) 174 | End If 175 | 176 | ClearSort 177 | 178 | Dim startColumnNum As Long 179 | startColumnNum = Column(startColumn).Index 180 | 181 | Dim numRows As Long, numColumns As Long 182 | numRows = Min(ArrayLen(arr, 1), DataRowCount) 183 | If ArrayRank(arr) = 1 Then 184 | numColumns = 1 185 | Else 186 | numColumns = Min( _ 187 | ArrayLen(arr, 2), _ 188 | mListObject.ListColumns.Count - startColumnNum + 1) 189 | End If 190 | 191 | mListObject.DataBodyRange _ 192 | .Offset(0, startColumnNum - 1) _ 193 | .Resize(numRows, numColumns) _ 194 | .Value = arr 195 | End Sub 196 | 197 | ' Sorts this Excel table by the given column(s). 198 | ' @param columnSpecs: An array of or more column indices to sort by. These 199 | ' can be numbers (1-based column indices) or strings (column names). Column 200 | ' names can have ":asc" or ":desc" appended to them to sort in ascending or 201 | ' descending order (the default is ascending). 202 | Public Sub Sort(columnSpecs As Variant) 203 | If Not IsArray(columnSpecs) Then 204 | Err.Raise 32000, Description:= _ 205 | "When sorting a table, the column specifiers must be an array." 206 | End If 207 | 208 | columnSpecs = NormalizeArray(columnSpecs) 209 | If ArrayLen(columnSpecs) = 0 Then 210 | Err.Raise 32000, Description:= _ 211 | "When sorting a table, at least one sort field must be given." 212 | End If 213 | 214 | With mListObject.Sort 215 | .Header = xlYes 216 | .MatchCase = False 217 | .Orientation = xlTopToBottom 218 | .SortMethod = xlPinYin 219 | .SortFields.Clear 220 | 221 | Dim i As Integer, columnIndex As Variant, sortOrder As XlSortOrder 222 | For i = 1 To UBound(columnSpecs) 223 | columnIndex = columnSpecs(i) 224 | If EndsWith(CStr(columnIndex), ":asc", False) Then 225 | columnIndex = Left(columnIndex, Len(columnIndex) - 4) 226 | sortOrder = xlAscending 227 | ElseIf EndsWith(CStr(columnIndex), ":desc", False) Then 228 | columnIndex = Left(columnIndex, Len(columnIndex) - 5) 229 | sortOrder = xlDescending 230 | Else 231 | sortOrder = xlAscending 232 | End If 233 | 234 | .SortFields.Add Key:=ColumnRange(columnIndex), _ 235 | SortOn:=xlSortOnValues, Order:=sortOrder 236 | 237 | Next 238 | 239 | .Apply 240 | End With 241 | End Sub 242 | 243 | ' Clears any sorting applied to this Excel table. 244 | Public Sub ClearSort() 245 | mListObject.Sort.SortFields.Clear 246 | End Sub 247 | 248 | ' Creates a regular named range for each of this Excel table's columns. This 249 | ' is useful if other workbooks need to link to this table, since references to 250 | ' table formulas like TblData[ColName] don't work with closed workbooks. 251 | ' @param namePrefix: The prefix which will be prepended to the names of the 252 | ' named ranges created from this table. 253 | Public Sub CreateNamedRanges(namePrefix As String) 254 | Dim c As Long 255 | For c = 1 To mListObject.ListColumns.Count 256 | ' Get sheet then workbook 257 | mListObject.Parent.Parent.Names.Add _ 258 | Name:=namePrefix & Column(c).Name, _ 259 | RefersTo:="='" & mListObject.Parent.Name & "'!" _ 260 | & ColumnRange(c).Address(True, True) 261 | Next 262 | End Sub 263 | -------------------------------------------------------------------------------- /VBALib_ArrayUtils.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VBALib_ArrayUtils" 2 | ' Common VBA Library - ArrayUtils 3 | ' Provides functions for handling arrays that are lacking in the built-in VBA 4 | ' language. 5 | 6 | Option Explicit 7 | 8 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ 9 | (dest As Any, source As Any, ByVal bytes As Long) 10 | 11 | Private Const NORMALIZE_LBOUND = 1 12 | 13 | ' Returns a single-dimension array with lower bound 1, if given a 14 | ' one-dimensional array with any lower bound or a two-dimensional array with 15 | ' one dimension having only one element. This function will always return a 16 | ' copy of the given array. 17 | Public Function NormalizeArray(arr As Variant) As Variant 18 | If ArrayLen(arr) = 0 Then 19 | NormalizeArray = Array() 20 | Exit Function 21 | End If 22 | 23 | Dim arr2() As Variant 24 | 25 | Dim nItems As Long 26 | Dim i As Long 27 | 28 | Select Case ArrayRank(arr) 29 | Case 1 30 | If LBound(arr) = NORMALIZE_LBOUND Then 31 | NormalizeArray = arr 32 | Else 33 | nItems = ArrayLen(arr) 34 | ReDim arr2(NORMALIZE_LBOUND To NORMALIZE_LBOUND + nItems - 1) 35 | For i = NORMALIZE_LBOUND To NORMALIZE_LBOUND + nItems - 1 36 | arr2(i) = arr(i + LBound(arr) - NORMALIZE_LBOUND) 37 | Next 38 | NormalizeArray = arr2 39 | End If 40 | 41 | Case 2 42 | If LBound(arr, 1) = UBound(arr, 1) Then 43 | 44 | ' Copy values from array's second dimension 45 | nItems = ArrayLen(arr, 2) 46 | ReDim arr2(NORMALIZE_LBOUND To NORMALIZE_LBOUND + nItems - 1) 47 | For i = NORMALIZE_LBOUND To NORMALIZE_LBOUND + nItems - 1 48 | arr2(i) = arr(LBound(arr, 1), _ 49 | i + LBound(arr, 2) - NORMALIZE_LBOUND) 50 | Next 51 | NormalizeArray = arr2 52 | 53 | ElseIf LBound(arr, 2) = UBound(arr, 2) Then 54 | 55 | ' Copy values from array's first dimension 56 | nItems = ArrayLen(arr, 1) 57 | ReDim arr2(NORMALIZE_LBOUND To NORMALIZE_LBOUND + nItems - 1) 58 | For i = NORMALIZE_LBOUND To NORMALIZE_LBOUND + nItems - 1 59 | arr2(i) = arr(i + LBound(arr, 1) - NORMALIZE_LBOUND, _ 60 | LBound(arr, 2)) 61 | Next 62 | NormalizeArray = arr2 63 | 64 | Else 65 | Err.Raise 32000, Description:= _ 66 | "Can only normalize a 2-dimensional array if one of " _ 67 | & "the dimensions contains only one element." 68 | End If 69 | 70 | Case Else 71 | Err.Raise 32000, Description:= _ 72 | "Can only normalize 1- and 2-dimensional arrays." 73 | End Select 74 | End Function 75 | 76 | ' Returns the rank (number of dimensions) of an array. 77 | ' From http://www.devx.com/vb2themax/Tip/18265 . 78 | Public Function ArrayRank(arr As Variant) As Integer 79 | Dim ptr As Long 80 | Dim vType As Integer 81 | Const VT_BYREF = &H4000& 82 | 83 | ' get the real VarType of the argument 84 | ' this is similar to VarType(), but returns also the VT_BYREF bit 85 | CopyMemory vType, arr, 2 86 | 87 | ' exit if not an array 88 | If (vType And vbArray) = 0 Then Exit Function 89 | 90 | ' get the address of the SAFEARRAY descriptor 91 | ' this is stored in the second half of the 92 | ' Variant parameter that has received the array 93 | CopyMemory ptr, ByVal VarPtr(arr) + 8, 4 94 | 95 | ' see whether the routine was passed a Variant 96 | ' that contains an array, rather than directly an array 97 | ' in the former case ptr already points to the SA structure. 98 | ' Thanks to Monte Hansen for this fix 99 | If (vType And VT_BYREF) Then 100 | ' ptr is a pointer to a pointer 101 | CopyMemory ptr, ByVal ptr, 4 102 | End If 103 | 104 | ' get the address of the SAFEARRAY structure 105 | ' this is stored in the descriptor 106 | ' get the first word of the SAFEARRAY structure 107 | ' which holds the number of dimensions 108 | ' ...but first check that saAddr is non-zero, otherwise 109 | ' this routine bombs when the array is uninitialized 110 | ' (Thanks to VB2TheMax aficionado Thomas Eyde for 111 | ' suggesting this edit to the original routine.) 112 | If ptr Then 113 | CopyMemory ArrayRank, ByVal ptr, 2 114 | End If 115 | End Function 116 | 117 | ' Returns the number of elements in an array for a given dimension. 118 | Public Function ArrayLen(arr As Variant, _ 119 | Optional dimNum As Integer = 1) As Long 120 | 121 | If IsEmpty(arr) Then 122 | ArrayLen = 0 123 | Else 124 | ArrayLen = UBound(arr, dimNum) - LBound(arr, dimNum) + 1 125 | End If 126 | End Function 127 | 128 | ' Sorts a section of an array in place. Code from: 129 | ' http://stackoverflow.com/questions/152319/vba-array-sort-function 130 | Private Sub QuickSort(vArray() As Variant, inLow As Long, inHi As Long) 131 | Dim pivot As Variant 132 | Dim tmpSwap As Variant 133 | Dim tmpLow As Long 134 | Dim tmpHi As Long 135 | 136 | tmpLow = inLow 137 | tmpHi = inHi 138 | 139 | pivot = vArray((inLow + inHi) \ 2) 140 | 141 | While (tmpLow <= tmpHi) 142 | 143 | While (vArray(tmpLow) < pivot And tmpLow < inHi) 144 | tmpLow = tmpLow + 1 145 | Wend 146 | 147 | While (pivot < vArray(tmpHi) And tmpHi > inLow) 148 | tmpHi = tmpHi - 1 149 | Wend 150 | 151 | If (tmpLow <= tmpHi) Then 152 | tmpSwap = vArray(tmpLow) 153 | vArray(tmpLow) = vArray(tmpHi) 154 | vArray(tmpHi) = tmpSwap 155 | tmpLow = tmpLow + 1 156 | tmpHi = tmpHi - 1 157 | End If 158 | 159 | Wend 160 | 161 | If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi 162 | If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi 163 | End Sub 164 | 165 | ' Sorts the given single-dimension array in place. 166 | Public Sub SortArrayInPlace(arr() As Variant) 167 | QuickSort arr, LBound(arr), UBound(arr) 168 | End Sub 169 | 170 | ' Returns a sorted copy of the given array. 171 | Public Function SortArray(arr() As Variant) As Variant() 172 | If ArrayLen(arr) = 0 Then 173 | SortArray = Array() 174 | Else 175 | Dim arr2() As Variant 176 | arr2 = arr 177 | SortArrayInPlace arr2 178 | SortArray = arr2 179 | End If 180 | End Function 181 | 182 | ' Returns an array containing each unique item in the given array only once. 183 | Public Function GetUniqueItems(arr() As Variant) As Variant() 184 | If ArrayLen(arr) = 0 Then 185 | GetUniqueItems = Array() 186 | Else 187 | Dim arrSorted() As Variant 188 | arrSorted = SortArray(arr) 189 | 190 | Dim uniqueItemsList As New VBALib_List 191 | uniqueItemsList.Add arrSorted(LBound(arrSorted)) 192 | 193 | Dim i As Long 194 | For i = LBound(arrSorted) + 1 To UBound(arrSorted) 195 | If arrSorted(i) <> arrSorted(i - 1) Then 196 | uniqueItemsList.Add arrSorted(i) 197 | End If 198 | Next 199 | 200 | GetUniqueItems = uniqueItemsList.Items 201 | End If 202 | End Function 203 | 204 | ' Returns the subset of the given one- or two-dimensional array specified by 205 | ' the given bounds. The returned array will have lower bounds of 1. 206 | ' @param arr: The array to process. 207 | ' @param r1: The index of the first element to be extracted from the first 208 | ' dimension of the array. If not given, defaults to the lower bound of the 209 | ' first dimension. 210 | ' @param r2: The index of the last element to be extracted from the first 211 | ' dimension of the array. If not given, defaults to the upper bound of the 212 | ' first dimension. 213 | ' @param c1: The index of the first element to be extracted from the second 214 | ' dimension of the array. If not given, defaults to the lower bound of the 215 | ' second dimension. 216 | ' @param c2: The index of the last element to be extracted from the second 217 | ' dimension of the array. If not given, defaults to the upper bound of the 218 | ' second dimension. 219 | Public Function ArraySubset(arr() As Variant, _ 220 | Optional r1 As Long = -1, Optional r2 As Long = -1, _ 221 | Optional c1 As Long = -1, Optional c2 As Long = -1) As Variant() 222 | 223 | Dim arr2() As Variant 224 | Dim i As Long, j As Long 225 | 226 | If r1 < 0 Then r1 = LBound(arr, 1) 227 | If r2 < 0 Then r2 = UBound(arr, 1) 228 | 229 | Select Case ArrayRank(arr) 230 | Case 1 231 | If c1 >= 0 Or c2 >= 0 Then 232 | Err.Raise 32000, Description:= _ 233 | "Too many array dimensions passed to ArraySubset." 234 | End If 235 | ReDim arr2( _ 236 | NORMALIZE_LBOUND To NORMALIZE_LBOUND + r2 - r1) 237 | For i = r1 To r2 238 | arr2( _ 239 | i - r1 + NORMALIZE_LBOUND) = arr(i) 240 | Next 241 | 242 | Case 2 243 | If c1 < 0 Then c1 = LBound(arr, 2) 244 | If c2 < 0 Then c2 = UBound(arr, 2) 245 | ReDim arr2( _ 246 | NORMALIZE_LBOUND To NORMALIZE_LBOUND + r2 - r1, _ 247 | NORMALIZE_LBOUND To NORMALIZE_LBOUND + c2 - c1) 248 | For i = r1 To r2 249 | For j = c1 To c2 250 | arr2( _ 251 | i - r1 + NORMALIZE_LBOUND, _ 252 | j - c1 + NORMALIZE_LBOUND) = arr(i, j) 253 | Next j, i 254 | 255 | Case Else 256 | Err.Raise 32000, Description:= _ 257 | "Can only take a subset of a 1- or 2-dimensional array." 258 | End Select 259 | 260 | ArraySubset = arr2 261 | End Function 262 | 263 | ' Returns the index of the given value in the given array, or one less than 264 | ' the lower bound of the array if the value is not found in the array. 265 | ' @param arr: The array to search through. 266 | ' @param val: The value to search for. 267 | Public Function ArrayIndexOf(arr As Variant, val As Variant) As Long 268 | ArrayIndexOf = LBound(arr) - 1 269 | Dim i As Long 270 | For i = LBound(arr) To UBound(arr) 271 | If arr(i) = val Then 272 | ArrayIndexOf = i 273 | Exit Function 274 | End If 275 | Next 276 | End Function 277 | 278 | ' Returns whether the given array contains the given value. 279 | ' @param arr: The array to search through. 280 | ' @param val: The value to search for. 281 | Public Function ArrayContains(arr As Variant, val As Variant) As Boolean 282 | ArrayContains = (ArrayIndexOf(arr, val) >= LBound(arr)) 283 | End Function 284 | -------------------------------------------------------------------------------- /VBALib_ExportImportSheets.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VBALib_ExportImportSheets" 2 | ' Common VBA Library - ExportImportSheets 3 | ' Provides functions for moving sheets of one workbook to another workbook, 4 | ' breaking links along the way. Useful for sending the results of a workbook 5 | ' to others, or for saving key data items to another workbook. 6 | 7 | Option Explicit 8 | 9 | Const COL_FOLDER = 1 10 | Const COL_FILENAME = 2 11 | Const COL_SHEETNAME = 3 12 | Const COL_NEWSHEETNAME = 4 13 | 14 | ' Imports Excel sheets from one or more workbooks into the given workbook, 15 | ' breaking any links and converting them to values. 16 | ' @param sheetsSpec: A two-dimensional array that describes the sheets to 17 | ' import into the workbook. It should have one or more indices in its first 18 | ' dimension, and indices 1-3 (or 1-4) in its second dimension as follows: 19 | ' - Index 1 (Folder) is the folder that this row's workbook appears in. 20 | ' - Index 2 (Filename) is the filename of this row's workbook. 21 | ' - Index 3 (SheetName) is the sheet to extract from this row's workbook. 22 | ' - Index 4 (NewSheetName) is optional. If present, the sheet described 23 | ' by this row will be renamed to the NewSheetName after extraction. 24 | ' @param wb: The workbook that will receive the imported sheets (defaults to 25 | ' the workbook that contains this code). 26 | Public Sub ImportExcelSheets(sheetsSpec() As Variant, Optional wb As Workbook) 27 | If wb Is Nothing Then Set wb = ThisWorkbook 28 | 29 | CopyExcelSheets wb, sheetsSpec, False 30 | End Sub 31 | 32 | ' Exports Excel sheets from one or more workbooks into a new workbook, 33 | ' breaking any links and converting them to values. Returns True if the 34 | ' workbook was saved, or False if it was not saved. 35 | ' @param sheetsSpec: A two-dimensional array that describes the sheets to 36 | ' export to the new workbook. This array has the same structure as in 37 | ' ImportExcelSheets, with the added feature that if the folder is blank and 38 | ' the filename is the string ThisWorkbook then the sheet to be exported will 39 | ' come from the current workbook. 40 | ' @param wb: The workbook that will receive the imported sheets (defaults to 41 | ' the active workbook). 42 | Public Function ExportExcelSheets(sheetsSpec() As Variant, _ 43 | wbFilename As String, Optional oAction As OverwriteAction = oaPrompt, _ 44 | Optional openReadOnly As Boolean = False) As Boolean 45 | 46 | Dim wb As Workbook 47 | Set wb = Workbooks.Add 48 | 49 | While wb.Sheets.Count > 1 50 | DeleteSheet wb.Sheets(2) 51 | Wend 52 | 53 | CopyExcelSheets wb, sheetsSpec, True 54 | 55 | DeleteSheet wb.Sheets(1) 56 | 57 | ExportExcelSheets = SaveWorkbookAs(wb, wbFilename, oAction, openReadOnly) 58 | 59 | wb.Close SaveChanges:=False 60 | End Function 61 | 62 | Private Sub CopyExcelSheets(wb As Workbook, sheetsSpec() As Variant, _ 63 | allowThisWorkbook As Boolean) 64 | 65 | Dim prevActiveSheet As Worksheet 66 | Set prevActiveSheet = wb.ActiveSheet 67 | 68 | Dim i1 As Long, i2 As Long 69 | i1 = LBound(sheetsSpec, 1) 70 | i2 = UBound(sheetsSpec, 1) 71 | 72 | ' The workbooks which contain the sheets we're interested in 73 | Dim wbFilenames() As String 74 | ReDim wbFilenames(i1 To i2) 75 | 76 | ' The names of the sheets we're interested in 77 | Dim sheetNames() As String 78 | ReDim sheetNames(i1 To i2) 79 | 80 | ' The new names of the sheets we're interested in 81 | Dim newSheetNames() As String 82 | ReDim newSheetNames(i1 To i2) 83 | 84 | ' The desired position of each sheet (this array stores a sheet name that 85 | ' the sheet will be placed immediately after, or the empty string if the 86 | ' sheet should be placed at the beginning of the workbook) 87 | Dim sheetPositions() As String 88 | ReDim sheetPositions(i1 To i2) 89 | 90 | ' The order in which sheets need to be moved when they are rearranged. To 91 | ' see why this is necessary, imagine that a workbook contains sheets A, B, 92 | ' C, and D, but the program obtains these sheets in the order A, C, B, D. 93 | ' When rearranging sheets, A would be moved to its position (correctly), 94 | ' then C would be moved to its position after B, but since B was not in the 95 | ' desired position, then C would not be moved to its desired position 96 | ' either. To solve this, store the order of the existing sheets in the 97 | ' workbook, and move the new sheets in that order. 98 | Dim sheetMoveOrder() As Long 99 | ReDim sheetMoveOrder(i1 To i2) 100 | ' Supporting variables for sheetMoveOrder. 101 | Dim sheetIndex As Long, sheetMoveOrderIndex As Long 102 | 103 | ' The list of Excel links to other workbooks that could not be broken. 104 | Dim linksFailedToBreak As New VBALib_List 105 | 106 | Dim i As Long 107 | For i = i1 To i2 108 | Dim thisFolderName As String, thisFilename As String 109 | thisFolderName = CStr(sheetsSpec(i, COL_FOLDER)) 110 | thisFilename = CStr(sheetsSpec(i, COL_FILENAME)) 111 | If thisFolderName = "" Or thisFilename = "" Then 112 | wbFilenames(i) = thisFolderName & thisFilename 113 | Else 114 | wbFilenames(i) = NormalizePath(CombinePaths( _ 115 | thisFolderName, thisFilename)) 116 | End If 117 | 118 | If LCase(wbFilenames(i)) = "thisworkbook" Then 119 | If allowThisWorkbook Then 120 | wbFilenames(i) = "ThisWorkbook" 121 | Else 122 | Err.Raise 32000, Description:= _ 123 | "Cannot import Excel sheets from ThisWorkbook." 124 | End If 125 | End If 126 | 127 | sheetNames(i) = sheetsSpec(i, COL_SHEETNAME) 128 | 129 | If COL_NEWSHEETNAME <= UBound(sheetsSpec, 2) Then 130 | newSheetNames(i) = sheetsSpec(i, COL_NEWSHEETNAME) 131 | Else 132 | newSheetNames(i) = "" 133 | End If 134 | If newSheetNames(i) = "" Then 135 | newSheetNames(i) = sheetNames(i) 136 | End If 137 | 138 | If SheetExists(newSheetNames(i), wb) Then 139 | sheetIndex = wb.Sheets(newSheetNames(i)).Index 140 | If sheetIndex = 1 Then 141 | sheetPositions(i) = "" 142 | Else 143 | sheetPositions(i) = wb.Sheets(sheetIndex - 1).Name 144 | End If 145 | ElseIf i = i1 Then 146 | sheetPositions(i) = wb.Sheets(wb.Sheets.Count).Name 147 | Else 148 | sheetPositions(i) = newSheetNames(i - 1) 149 | End If 150 | 151 | sheetMoveOrder(i) = i1 - 1 152 | Next 153 | 154 | ' Determine the order in which we need to rearrange sheets. Start by 155 | ' looping over all of the workbook's current sheets, and checking if they 156 | ' are sheets that will be replaced during this run. If so, then rearrange 157 | ' them in that order. 158 | sheetMoveOrderIndex = i1 159 | For sheetIndex = 1 To wb.Sheets.Count 160 | i = ArrayIndexOf(newSheetNames, wb.Sheets(sheetIndex).Name) 161 | If i >= i1 Then 162 | sheetMoveOrder(sheetMoveOrderIndex) = i 163 | sheetMoveOrderIndex = sheetMoveOrderIndex + 1 164 | End If 165 | Next 166 | ' Now, add any sheets that will be added to the workbook, but do not exist 167 | ' yet. Ensure that these sheets are arranged according to the order in 168 | ' the specification passed to this function. 169 | For i = i1 To i2 170 | If Not ArrayContains(sheetMoveOrder, i) Then 171 | sheetMoveOrder(sheetMoveOrderIndex) = i 172 | sheetMoveOrderIndex = sheetMoveOrderIndex + 1 173 | End If 174 | Next 175 | ' Sanity check 176 | 'If sheetMoveOrderIndex <> i2 + 1 Then Stop 177 | 178 | Dim currentFilename As String 179 | Dim currentWb As Workbook 180 | Dim filesProcessed As New VBALib_List 181 | Dim sheetsToCopy As New VBALib_List 182 | Dim oldLinkNames As New VBALib_List 183 | Dim newLinkNames As New VBALib_List 184 | 185 | Do 186 | currentFilename = "" 187 | sheetsToCopy.Clear 188 | 189 | For i = i1 To i2 190 | If currentFilename = "" Then 191 | If Not filesProcessed.Contains(LCase(wbFilenames(i))) Then 192 | currentFilename = wbFilenames(i) 193 | filesProcessed.Add LCase(wbFilenames(i)) 194 | Set currentWb = Nothing 195 | End If 196 | End If 197 | 198 | If LCase(currentFilename) = LCase(wbFilenames(i)) Then 199 | If currentWb Is Nothing Then 200 | If currentFilename = "ThisWorkbook" Then 201 | Set currentWb = ThisWorkbook 202 | Else 203 | ShowStatusMessage "Opening workbook: " _ 204 | & GetFilename(currentFilename) 205 | If IsWorkbookOpen(GetFilename(currentFilename)) Then 206 | Set currentWb = Workbooks( _ 207 | GetFilename(currentFilename)) 208 | Else 209 | Set currentWb = Workbooks.Open(wbFilenames(i), _ 210 | ReadOnly:=True, _ 211 | UpdateLinks:=False) 212 | End If 213 | ClearStatusMessage 214 | End If 215 | End If 216 | 217 | If SheetExists(newSheetNames(i), wb) Then 218 | ShowStatusMessage "Deleting sheet: " & newSheetNames(i) 219 | DeleteSheetByName newSheetNames(i), wb 220 | ClearStatusMessage 221 | End If 222 | 223 | ' Instead of copying sheets one at a time, save a list of the 224 | ' sheet names we need to copy and do them all at once. This 225 | ' way is much faster. 226 | sheetsToCopy.Add sheetNames(i) 227 | End If 228 | Next 229 | 230 | If Not currentWb Is Nothing Then 231 | Dim oldSheetCount As Long 232 | oldSheetCount = wb.Sheets.Count 233 | 234 | ' Store the list of linked files in the workbook before copying 235 | ' sheets over, because copying a sheet can add more than one link. 236 | oldLinkNames.Clear 237 | On Error Resume Next ' wb.LinkSources returns Empty if no links 238 | oldLinkNames.AddRange wb.LinkSources(xlExcelLinks) 239 | On Error GoTo 0 240 | 241 | ShowStatusMessage "Copying sheets from workbook: " _ 242 | & currentWb.Name 243 | currentWb.Sheets(sheetsToCopy.Items).Copy _ 244 | After:=wb.Sheets(wb.Sheets.Count) 245 | 246 | ' Unhide any sheets that were hidden when copied over. 247 | For i = oldSheetCount + 1 To wb.Sheets.Count 248 | wb.Sheets(i).Visible = xlSheetVisible 249 | Next 250 | 251 | For i = i1 To i2 252 | If LCase(currentFilename) = LCase(wbFilenames(i)) _ 253 | And sheetNames(i) <> newSheetNames(i) Then 254 | 255 | ShowStatusMessage "Renaming sheet: " & newSheetNames(i) 256 | wb.Sheets(sheetNames(i)).Name = newSheetNames(i) 257 | End If 258 | Next 259 | 260 | ' Get the list of links again, and remove any that didn't exist 261 | ' before, as well as any link to the workbook that contains the 262 | ' sheet(s) we're currently copying. 263 | newLinkNames.Clear 264 | newLinkNames.AddRange wb.LinkSources(xlExcelLinks) 265 | If ExcelLinkExists(currentWb.Name, wb) Then 266 | newLinkNames.AddOnce currentWb.FullName 267 | End If 268 | 269 | Dim linkName_ As Variant, linkName As String 270 | For Each linkName_ In newLinkNames.Items 271 | linkName = linkName_ 272 | ' Always try to remove the link to the current workbook, even 273 | ' if it already existed. 274 | If LCase(GetFilename(linkName)) = LCase(currentWb.Name) _ 275 | Or Not oldLinkNames.Contains(linkName) Then 276 | 277 | ShowStatusMessage "Breaking link to workbook: " _ 278 | & GetFilename(linkName) 279 | Dim currentWbLink As VBALib_ExcelLink 280 | Set currentWbLink = GetExcelLink(linkName, wb) 281 | If Not currentWbLink.Break(False) Then 282 | linksFailedToBreak.Add GetFilename(linkName) 283 | End If 284 | End If 285 | Next 286 | 287 | If currentFilename <> "ThisWorkbook" Then 288 | ShowStatusMessage "Closing workbook: " & currentWb.Name 289 | currentWb.Close SaveChanges:=False 290 | End If 291 | Set currentWb = Nothing 292 | 293 | ClearStatusMessage 294 | End If 295 | Loop While currentFilename <> "" 296 | 297 | ShowStatusMessage "Rearranging sheets" 298 | For i = i1 To i2 299 | If sheetPositions(sheetMoveOrder(i)) = "" Then 300 | wb.Sheets(newSheetNames(sheetMoveOrder(i))).Move _ 301 | Before:=wb.Sheets(1) 302 | ElseIf SheetExists(sheetPositions(sheetMoveOrder(i)), wb) Then 303 | wb.Sheets(newSheetNames(sheetMoveOrder(i))).Move _ 304 | After:=wb.Sheets(sheetPositions(sheetMoveOrder(i))) 305 | End If 306 | Next 307 | ClearStatusMessage 308 | 309 | If linksFailedToBreak.Count Then 310 | MsgBox Prompt:="Failed to break links to one or more workbooks:" _ 311 | & vbLf & vbLf & Join(linksFailedToBreak.Items, vbLf), _ 312 | Title:="Excel link failure", _ 313 | Buttons:=vbOKOnly + vbExclamation 314 | End If 315 | 316 | prevActiveSheet.Activate 317 | End Sub 318 | -------------------------------------------------------------------------------- /VBALib_ExcelUtils.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VBALib_ExcelUtils" 2 | ' Common VBA Library - ExcelUtils 3 | ' Provides useful functions for working with the Excel object model. 4 | 5 | Option Explicit 6 | 7 | Private Declare Function CallNamedPipe Lib "kernel32" _ 8 | Alias "CallNamedPipeA" ( _ 9 | ByVal lpNamedPipeName As String, _ 10 | ByVal lpInBuffer As Any, ByVal nInBufferSize As Long, _ 11 | ByRef lpOutBuffer As Any, ByVal nOutBufferSize As Long, _ 12 | ByRef lpBytesRead As Long, ByVal nTimeOut As Long) As Long 13 | 14 | Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long 15 | 16 | Public Enum Corner 17 | cnrTopLeft 18 | cnrTopRight 19 | cnrBottomLeft 20 | cnrBottomRight 21 | End Enum 22 | 23 | Public Enum OverwriteAction 24 | oaPrompt = 1 25 | oaOverwrite = 2 26 | oaSkip = 3 27 | oaError = 4 28 | oaCreateDirectory = 8 29 | End Enum 30 | 31 | ' Determines whether a given workbook has been opened. Pass this function 32 | ' a filename only, not a full path. 33 | Public Function IsWorkbookOpen(wbFilename As String) As Boolean 34 | Dim w As Workbook 35 | 36 | On Error GoTo notOpen 37 | Set w = Workbooks(wbFilename) 38 | IsWorkbookOpen = True 39 | Exit Function 40 | 41 | notOpen: 42 | IsWorkbookOpen = False 43 | End Function 44 | 45 | ' Determines whether a sheet with the given name exists. 46 | ' @param wb: The workbook to check for the given sheet name (defaults to the 47 | ' active workbook). 48 | Public Function SheetExists(sheetName As String, Optional wb As Workbook) _ 49 | As Boolean 50 | 51 | If wb Is Nothing Then Set wb = ActiveWorkbook 52 | Dim s As Object ' Not Worksheet because it could also be a chart 53 | 54 | On Error GoTo notFound 55 | Set s = wb.Sheets(sheetName) 56 | SheetExists = True 57 | Exit Function 58 | 59 | notFound: 60 | SheetExists = False 61 | End Function 62 | 63 | ' Determines whether a chart with the given name exists. 64 | ' @param chartName: The name of the chart to check for. 65 | ' @param sheetName: The name of the worksheet that contains the given chart 66 | ' (optional; the default is to search all worksheets). 67 | ' @param wb: The workbook to check for the given chart name (defaults to the 68 | ' active workbook. 69 | Public Function ChartExists(chartName As String, _ 70 | Optional sheetName As String = "", Optional wb As Workbook) As Boolean 71 | 72 | If wb Is Nothing Then Set wb = ActiveWorkbook 73 | 74 | Dim s As Worksheet 75 | Dim c As ChartObject 76 | 77 | ChartExists = False 78 | 79 | If sheetName = "" Then 80 | For Each s In wb.Sheets 81 | If ChartExists(chartName, s.Name, wb) Then 82 | ChartExists = True 83 | Exit Function 84 | End If 85 | Next 86 | Else 87 | Set s = wb.Sheets(sheetName) 88 | On Error GoTo notFound 89 | Set c = s.ChartObjects(chartName) 90 | ChartExists = True 91 | notFound: 92 | End If 93 | End Function 94 | 95 | ' Deletes the sheet with the given name, without prompting for confirmation. 96 | ' @param wb: The workbook to check for the given sheet name (defaults to the 97 | ' active workbook). 98 | Public Sub DeleteSheetByName(sheetName As String, Optional wb As Workbook) 99 | If wb Is Nothing Then Set wb = ActiveWorkbook 100 | If SheetExists(sheetName, wb) Then DeleteSheetOrSheets wb.Sheets(sheetName) 101 | End Sub 102 | 103 | ' Deletes the given worksheet, without prompting for confirmation. 104 | Public Sub DeleteSheet(s As Worksheet) 105 | DeleteSheetOrSheets s 106 | End Sub 107 | 108 | ' Deletes all sheets in the given Sheets object, without prompting for 109 | ' confirmation. 110 | Public Sub DeleteSheets(s As Sheets) 111 | DeleteSheetOrSheets s 112 | End Sub 113 | 114 | Private Sub DeleteSheetOrSheets(s As Object) 115 | Dim prevDisplayAlerts As Boolean 116 | prevDisplayAlerts = Application.DisplayAlerts 117 | Application.DisplayAlerts = False 118 | On Error Resume Next 119 | s.Delete 120 | On Error GoTo 0 121 | Application.DisplayAlerts = prevDisplayAlerts 122 | End Sub 123 | 124 | ' Returns the actual used range from a sheet. 125 | ' @param fromTopLeft: If True, returns the used range starting from cell A1, 126 | ' which is different from the way Excel's UsedRange property behaves if the 127 | ' sheet does not use any cells in the top row(s) and/or leftmost column(s). 128 | Public Function GetRealUsedRange(s As Worksheet, _ 129 | Optional fromTopLeft As Boolean = True) As Range 130 | 131 | If fromTopLeft Then 132 | Set GetRealUsedRange = s.Range( _ 133 | s.Cells(1, 1), _ 134 | s.Cells( _ 135 | s.UsedRange.Rows.Count + s.UsedRange.Row - 1, _ 136 | s.UsedRange.Columns.Count + s.UsedRange.Column - 1)) 137 | Else 138 | Set GetRealUsedRange = s.UsedRange 139 | End If 140 | End Function 141 | 142 | ' Sets the value of the given range if it is different than the proposed value. 143 | ' Returns whether the value of the range was changed. 144 | Public Function SetValueIfNeeded(rng As Range, val As Variant) As Boolean 145 | If rng.Value = val Then 146 | SetValueIfNeeded = False 147 | Else 148 | rng.Value = val 149 | SetValueIfNeeded = True 150 | End If 151 | End Function 152 | 153 | ' Converts an integer column number to an Excel column string. 154 | Public Function ExcelCol(c As Integer) As String 155 | ExcelCol = ExcelCol_ZeroBased(c - 1) 156 | End Function 157 | 158 | Private Function ExcelCol_ZeroBased(c As Integer) As String 159 | Dim c2 As Integer 160 | c2 = c \ 26 161 | If c2 = 0 Then 162 | ExcelCol_ZeroBased = Chr(65 + c) 163 | Else 164 | ExcelCol_ZeroBased = ExcelCol(c2) & Chr(65 + (c Mod 26)) 165 | End If 166 | End Function 167 | 168 | ' Converts an Excel column string to an integer column number. 169 | Public Function ExcelColNum(c As String) As Integer 170 | ExcelColNum = 0 171 | Dim i As Integer 172 | For i = 1 To Len(c) 173 | ExcelColNum = (ExcelColNum + Asc(Mid(c, i, 1)) - 64) 174 | If i < Len(c) Then ExcelColNum = ExcelColNum * 26 175 | Next 176 | End Function 177 | 178 | ' Builds an Excel cell reference. 179 | Public Function CellReference(ByVal r As Long, ByVal c As Integer, _ 180 | Optional sheet As String = "", Optional absoluteRow As Boolean = False, _ 181 | Optional absoluteCol As Boolean = False) As String 182 | 183 | Dim ref As String 184 | ref = IIf(absoluteCol, "$", "") & ExcelCol(c) _ 185 | & IIf(absoluteRow, "$", "") & r 186 | 187 | If sheet = "" Then 188 | CellReference = ref 189 | Else 190 | CellReference = "'" & Replace(sheet, "'", "''") & "'!" & ref 191 | End If 192 | End Function 193 | 194 | ' Returns a string describing the type of an Excel error value 195 | ' ("#DIV/0!", "#N/A", etc.) 196 | Public Function ExcelErrorType(e As Variant) As String 197 | If IsError(e) Then 198 | Select Case e 199 | Case CVErr(xlErrDiv0) 200 | ExcelErrorType = "#DIV/0!" 201 | Case CVErr(xlErrNA) 202 | ExcelErrorType = "#N/A" 203 | Case CVErr(xlErrName) 204 | ExcelErrorType = "#NAME?" 205 | Case CVErr(xlErrNull) 206 | ExcelErrorType = "#NULL!" 207 | Case CVErr(xlErrNum) 208 | ExcelErrorType = "#NUM!" 209 | Case CVErr(xlErrRef) 210 | ExcelErrorType = "#REF!" 211 | Case CVErr(xlErrValue) 212 | ExcelErrorType = "#VALUE!" 213 | Case Else 214 | ExcelErrorType = "#UNKNOWN_ERROR" 215 | End Select 216 | Else 217 | ExcelErrorType = "(not an error)" 218 | End If 219 | End Function 220 | 221 | ' Shows a status message to update the user on the progress of a long-running 222 | ' operation, in a way that can be detected by external applications. 223 | Public Sub ShowStatusMessage(statusMessage As String) 224 | ' Show the message in the status bar. 225 | Application.StatusBar = statusMessage 226 | 227 | ' Set the Excel window title to the updated status message. The window 228 | ' title as seen by the Windows API will then be: 229 | ' "Status Message - WorkbookFilename.xlsm" 230 | ' To allow external applications to extract just the status message, 231 | ' put the length of the message at the beginning. 232 | Application.Caption = Len(statusMessage) & ":" & statusMessage 233 | End Sub 234 | 235 | ' Shows a status message for 2-3 seconds then removes it. 236 | Public Sub FlashStatusMessage(statusMessage As String) 237 | ShowStatusMessage statusMessage 238 | Application.OnTime Now + TimeValue("0:00:02"), "ClearStatusMessage" 239 | End Sub 240 | 241 | ' Clears any status message that is currently being displayed by a macro. 242 | Public Sub ClearStatusMessage() 243 | Application.StatusBar = False 244 | Application.Caption = Empty 245 | End Sub 246 | 247 | ' Attempts to send a message to an external program that is running this macro 248 | ' and listening for messages. 249 | Public Sub SendMessageToListener(msg As String) 250 | Dim bArray(0 To 0) As Byte 251 | Dim bytesRead As Long 252 | CallNamedPipe _ 253 | "\\.\pipe\ExcelMacroCommunicationListener." & GetCurrentProcessId, _ 254 | msg, Len(msg), bArray(0), 1, bytesRead, 500 255 | End Sub 256 | 257 | ' Returns the cell in the given corner of the given range. 258 | Public Function GetCornerCell(r As Range, c As Corner) As Range 259 | Select Case c 260 | Case cnrTopLeft 261 | Set GetCornerCell = r.Cells(1, 1) 262 | Case cnrTopRight 263 | Set GetCornerCell = r.Cells(1, r.Columns.Count) 264 | Case cnrBottomLeft 265 | Set GetCornerCell = r.Cells(r.Rows.Count, 1) 266 | Case cnrBottomRight 267 | Set GetCornerCell = r.Cells(r.Rows.Count, r.Columns.Count) 268 | End Select 269 | End Function 270 | 271 | ' Returns an array of objects representing the other Excel workbooks that the 272 | ' given workbook links to. 273 | ' @param wb: The source workbook (defaults to the active workbook). 274 | Public Function GetAllExcelLinks(Optional wb As Workbook) As Variant 275 | If wb Is Nothing Then Set wb = ActiveWorkbook 276 | 277 | Dim linkNames() As Variant 278 | linkNames = NormalizeArray(ActiveWorkbook.LinkSources(xlExcelLinks)) 279 | 280 | If ArrayLen(linkNames) Then 281 | Dim linksArr() As VBALib_ExcelLink 282 | ReDim linksArr(1 To ArrayLen(linkNames)) 283 | Dim i As Integer 284 | For i = 1 To UBound(linkNames) 285 | Set linksArr(i) = New VBALib_ExcelLink 286 | linksArr(i).Initialize wb, CStr(linkNames(i)) 287 | Next 288 | GetAllExcelLinks = linksArr 289 | Else 290 | GetAllExcelLinks = Array() 291 | Exit Function 292 | End If 293 | End Function 294 | 295 | Private Function GetMatchingLinkName(linkFilename As String, _ 296 | Optional wb As Workbook) As String 297 | 298 | If wb Is Nothing Then Set wb = ActiveWorkbook 299 | 300 | Dim linkNames() As Variant 301 | linkNames = NormalizeArray(wb.LinkSources(xlExcelLinks)) 302 | 303 | Dim i As Integer, matchingLinkName As String 304 | 305 | ' First look for a link with the exact full path given by linkFilename 306 | For i = 1 To UBound(linkNames) 307 | If LCase(linkNames(i)) = LCase(linkFilename) Then 308 | GetMatchingLinkName = linkNames(i) 309 | Exit Function 310 | End If 311 | Next 312 | 313 | ' Next look for a link with the same filename as linkFilename. Do it in 314 | ' two steps because it is actually possible for Excel to link to two 315 | ' workbooks with the same name in different folders. No one should ever 316 | ' do this, but we'll try to support retrieving such links anyway. 317 | For i = 1 To UBound(linkNames) 318 | If LCase(GetFilename(linkNames(i))) = _ 319 | LCase(GetFilename(linkFilename)) Then 320 | 321 | GetMatchingLinkName = linkNames(i) 322 | Exit Function 323 | End If 324 | Next 325 | 326 | GetMatchingLinkName = "" 327 | End Function 328 | 329 | ' Returns an object representing the link to the Excel workbook with the given 330 | ' filename. 331 | ' @param linkFilename: The path or filename of the linked Excel workbook. 332 | ' @param wb: The workbook that contains the link (defaults to the active 333 | ' workbook). 334 | Public Function GetExcelLink(linkFilename As String, Optional wb As Workbook) _ 335 | As VBALib_ExcelLink 336 | 337 | If wb Is Nothing Then Set wb = ActiveWorkbook 338 | 339 | Dim matchingLinkName As String 340 | matchingLinkName = GetMatchingLinkName(linkFilename, wb) 341 | 342 | If matchingLinkName = "" Then 343 | Err.Raise 32000, Description:= _ 344 | "No Excel link exists with the given name ('" & linkFilename _ 345 | & "')." 346 | Else 347 | Set GetExcelLink = New VBALib_ExcelLink 348 | GetExcelLink.Initialize wb, matchingLinkName 349 | End If 350 | End Function 351 | 352 | ' Returns whether an Excel link matching the given workbook filename exists. 353 | ' @param wb: The workbook that contains the link (defaults to the active 354 | ' workbook). 355 | Public Function ExcelLinkExists(linkFilename As String, _ 356 | Optional wb As Workbook) As Boolean 357 | 358 | ExcelLinkExists = (GetMatchingLinkName(linkFilename, wb) <> "") 359 | End Function 360 | 361 | ' Refreshes all Access database connections in the given workbook. 362 | ' @param wb: The workbook to refresh (defaults to the active workbook). 363 | Public Sub RefreshAccessConnections(Optional wb As Workbook) 364 | If wb Is Nothing Then Set wb = ActiveWorkbook 365 | 366 | Dim cn As WorkbookConnection 367 | 368 | On Error GoTo err_ 369 | Application.Calculation = xlCalculationManual 370 | 371 | Dim numConnections As Integer, i As Integer 372 | 373 | For Each cn In wb.Connections 374 | If cn.Type = xlConnectionTypeOLEDB Then 375 | numConnections = numConnections + 1 376 | End If 377 | Next 378 | 379 | For Each cn In wb.Connections 380 | If cn.Type = xlConnectionTypeOLEDB Then 381 | i = i + 1 382 | ShowStatusMessage "Refreshing data connection '" _ 383 | & cn.OLEDBConnection.CommandText _ 384 | & "' (" & i & " of " & numConnections & ")" 385 | cn.OLEDBConnection.BackgroundQuery = False 386 | cn.Refresh 387 | End If 388 | Next 389 | 390 | GoTo done_ 391 | err_: 392 | MsgBox "Error " & Err.Number & ": " & Err.Description 393 | 394 | done_: 395 | ShowStatusMessage "Recalculating" 396 | Application.Calculation = xlCalculationAutomatic 397 | Application.Calculate 398 | 399 | ClearStatusMessage 400 | End Sub 401 | 402 | ' Returns a wrapper object for the table with the given name in the given 403 | ' workbook. 404 | ' @param wb: The workbook that contains the table (defaults to the active 405 | ' workbook). 406 | Public Function GetExcelTable(tblName As String, Optional wb As Workbook) _ 407 | As VBALib_ExcelTable 408 | 409 | If wb Is Nothing Then Set wb = ActiveWorkbook 410 | 411 | On Error GoTo notFound 412 | 413 | Dim wbPrevActive As Workbook 414 | Set wbPrevActive = ActiveWorkbook 415 | wb.Activate 416 | 417 | ' We could just do Range(tblName).ListObject, but then this would allow 418 | ' getting a table by any of its cells or columns. Instead, do some 419 | ' verification that the string we were passed is actually the name of 420 | ' a table. 421 | Dim tbl As ListObject 422 | Set tbl = Range(tblName).Parent.ListObjects(tblName) 423 | 424 | wbPrevActive.Activate 425 | 426 | Set GetExcelTable = New VBALib_ExcelTable 427 | GetExcelTable.Initialize tbl 428 | Exit Function 429 | 430 | notFound: 431 | On Error GoTo 0 432 | Err.Raise 32000, Description:= _ 433 | "Could not find table '" & tblName & "'." 434 | End Function 435 | 436 | ' Returns the Excel workbook format for the given file extension. 437 | Public Function GetWorkbookFileFormat(fileExtension As String) As XlFileFormat 438 | Select Case LCase(Replace(fileExtension, ".", "")) 439 | Case "xls" 440 | GetWorkbookFileFormat = xlExcel8 441 | Case "xla" 442 | GetWorkbookFileFormat = xlAddIn8 443 | Case "xlt" 444 | GetWorkbookFileFormat = xlTemplate8 445 | Case "csv" 446 | GetWorkbookFileFormat = xlCSV 447 | Case "txt" 448 | GetWorkbookFileFormat = xlCurrentPlatformText 449 | Case "xlsx" 450 | GetWorkbookFileFormat = xlOpenXMLWorkbook 451 | Case "xlsm" 452 | GetWorkbookFileFormat = xlOpenXMLWorkbookMacroEnabled 453 | Case "xlsb" 454 | GetWorkbookFileFormat = xlExcel12 455 | Case "xlam" 456 | GetWorkbookFileFormat = xlOpenXMLAddIn 457 | Case "xltx" 458 | GetWorkbookFileFormat = xlOpenXMLTemplate 459 | Case "xltm" 460 | GetWorkbookFileFormat = xlOpenXMLTemplateMacroEnabled 461 | Case Else 462 | Err.Raise 32000, Description:= _ 463 | "Unrecognized Excel file extension: '" & fileExtension & "'" 464 | End Select 465 | End Function 466 | 467 | ' Saves the given workbook as a different filename, with options for handling 468 | ' the case where the file already exists. Returns True if the workbook was 469 | ' saved, or False if it was not saved. 470 | ' @param oAction: The action that will be taken if the given file exists. This 471 | ' parameter also accepts the oaCreateDirectory flag, which means that the 472 | ' directory hierarchy of the requested filename will be created if it does not 473 | ' already exist. If not given, defaults to oaPrompt. 474 | Public Function SaveWorkbookAs(wb As Workbook, newFilename As String, _ 475 | Optional oAction As OverwriteAction = oaPrompt, _ 476 | Optional openReadOnly As Boolean = False) As Boolean 477 | 478 | If Not FolderExists(GetDirectoryName(newFilename)) Then 479 | If oAction And oaCreateDirectory Then 480 | MkDirRecursive GetDirectoryName(newFilename) 481 | Else 482 | Err.Raise 32000, Description:= _ 483 | "The parent folder of the requested workbook filename " _ 484 | & "does not exist:" & vbLf & vbLf & newFilename 485 | End If 486 | End If 487 | 488 | If FileExists(newFilename) Then 489 | If oAction And oaOverwrite Then 490 | Kill newFilename 491 | ' Proceed to save the file 492 | 493 | ElseIf oAction And oaError Then 494 | Err.Raise 32000, Description:= _ 495 | "The given filename already exists:" _ 496 | & vbLf & vbLf & newFilename 497 | 498 | ElseIf oAction And oaPrompt Then 499 | Dim r As VbMsgBoxResult 500 | r = MsgBox(Title:="Overwrite Excel file?", _ 501 | Buttons:=vbYesNo + vbExclamation, _ 502 | Prompt:="The following Excel file already exists:" _ 503 | & vbLf & vbLf & newFilename & vbLf & vbLf _ 504 | & "Do you want to overwrite it?") 505 | If r = vbYes Then 506 | Kill newFilename 507 | ' Proceed to save the file 508 | Else 509 | SaveWorkbookAs = False 510 | Exit Function 511 | End If 512 | 513 | ElseIf oAction And oaSkip Then 514 | SaveWorkbookAs = False 515 | Exit Function 516 | 517 | Else 518 | Err.Raise 32000, Description:= _ 519 | "Bad overwrite action value passed to SaveWorkbookAs." 520 | 521 | End If 522 | End If 523 | 524 | ' wb.SaveCopyAs doesn't take all the fancy arguments that wb.SaveAs does, 525 | ' but it's the only way to save a copy of the current workbook. This 526 | ' means, among other things, that it is not possible to save the workbook 527 | ' as a different format than the original workbook. To work around this, 528 | ' call SaveCopyAs with a temporary filename first, then open the temporary 529 | ' file, then call SaveAs with the desired filename and options. 530 | 531 | Dim tmpFilename As String 532 | tmpFilename = CombinePaths(GetTempPath, Int(Rnd * 1000000) & "-" & wb.Name) 533 | wb.SaveCopyAs tmpFilename 534 | 535 | Dim wbTmp As Workbook 536 | Set wbTmp = Workbooks.Open(tmpFilename, UpdateLinks:=False, ReadOnly:=True) 537 | wbTmp.SaveAs filename:=newFilename, _ 538 | FileFormat:=GetWorkbookFileFormat(GetFileExtension(newFilename)), _ 539 | ReadOnlyRecommended:=openReadOnly 540 | wbTmp.Close SaveChanges:=False 541 | 542 | Kill tmpFilename 543 | 544 | SaveWorkbookAs = True 545 | End Function 546 | 547 | ' Saves the current workbook as a different filename, with options for handling 548 | ' the case where the file already exists. Returns True if the workbook was 549 | ' saved, or False if it was not saved. 550 | ' @param oAction: The action that will be taken if the given file exists. This 551 | ' parameter also accepts the oaCreateDirectory flag, which means that the 552 | ' directory hierarchy of the requested filename will be created if it does not 553 | ' already exist. If not given, defaults to oaPrompt. 554 | ' @param openReadOnly: True or False to determine whether the created workbook 555 | ' will prompt users to open it as read-only (defaults to False). 556 | Public Function SaveActiveWorkbookAs(newFilename As String, _ 557 | Optional oAction As OverwriteAction = oaPrompt, _ 558 | Optional openReadOnly As Boolean = False) As Boolean 559 | 560 | SaveActiveWorkbookAs = SaveWorkbookAs(ActiveWorkbook, newFilename, _ 561 | oAction, openReadOnly) 562 | End Function 563 | --------------------------------------------------------------------------------