├── .gitattributes ├── .gitignore ├── Core.bas ├── DateFunctions.bas ├── ErrorDetection.bas ├── ExcelToSql_SolutionToUpdatingTheWebViaExcel.xlsm ├── MoveRangeFunctions.bas ├── README.md ├── Sonya_VBA_Macros_Demo.xlsm ├── UpdatingTheWebViaExcelSpreadsheet.docx └── ValidationSheetFunctions.bas /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | 7 | # Standard to msysgit 8 | *.doc diff=astextplain 9 | *.DOC diff=astextplain 10 | *.docx diff=astextplain 11 | *.DOCX diff=astextplain 12 | *.dot diff=astextplain 13 | *.DOT diff=astextplain 14 | *.pdf diff=astextplain 15 | *.PDF diff=astextplain 16 | *.rtf diff=astextplain 17 | *.RTF diff=astextplain 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | README.md 2 | *.md -------------------------------------------------------------------------------- /Core.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Core" 2 | 'Sonya - General Functions 3 | Function copy_pasteValueOnly(ByRef rngToCopy As Range, ByRef rngToPasteIn As Range) 4 | rngToCopy.Copy 5 | Worksheets(rngToPasteIn.Worksheet.name).Activate 6 | rngToPasteIn.Select 7 | Selection.PasteSpecial xlPasteValues 8 | SendKeys "{ESC}" 9 | End Function 10 | Function emptyLastXcolumnsInRow(ByVal numberOfColumnsToEmpty As Integer, ByVal rangeAsString As String, ByVal sheetname As String) 11 | With Worksheets(sheetname) 12 | Dim r As Range 13 | Dim c As Range 14 | Dim i As Integer 15 | Dim counter As Integer 16 | counter = 0 17 | Set r = .Range(rangeAsString) 18 | For i = r.Cells.Count To 1 Step -1 19 | If counter < numberOfColumnsToEmpty Then 20 | r.Cells(i).Value = vbNullString 21 | counter = counter + 1 22 | Else 23 | Exit For 24 | End If 25 | Next i 26 | End With 27 | End Function 28 | Function emptyFirstXcolumnsInRow(ByVal numberOfColumnsToEmpty As Integer, ByVal rangeAsString As String, ByVal sheetname As String) 29 | With Worksheets(sheetname) 30 | Dim r As Range 31 | Dim c As Range 32 | Dim i As Integer 33 | Dim counter As Integer 34 | counter = 0 35 | Set r = .Range(rangeAsString) 36 | For i = 1 To r.Cells.Count 37 | If counter < numberOfColumnsToEmpty Then 38 | r.Cells(i).Value = vbNullString 39 | counter = counter + 1 40 | Else 41 | Exit For 42 | End If 43 | Next i 44 | End With 45 | End Function 46 | Function getWholeCol(ByVal firstRowNum As Integer, ByVal sheetname As String, ByVal column As String) As Range 47 | Dim i As Integer 48 | i = firstRowNum 49 | Dim max As Integer 50 | With Worksheets(sheetname) 51 | Do Until i < 0 52 | If .Range(column & i) = vbNullString Then 53 | max = i - 1 54 | i = -1 55 | Else 56 | i = i + 1 57 | End If 58 | Loop 59 | Set getWholeCol = .Range(column & firstRowNum & ":" & column & max) 60 | End With 61 | End Function 62 | Function getNumberOfEmptyCellsAtTheEndOfRow(ByVal rngAsString As String, ByVal sheetname As String) As Integer 63 | With Worksheets(sheetname) 64 | Dim cellCount As Integer 65 | Dim rng As Range 66 | Set rng = .Range(rngAsString) 67 | cellCount = rng.Cells.Count 68 | Dim i As Integer 69 | Dim counter As Integer 70 | counter = 0 71 | For i = cellCount To 1 Step -1 72 | If rng.Cells(i) = vbNullString Then 73 | counter = counter + 1 74 | Else 75 | i = 0 76 | End If 77 | Next i 78 | End With 79 | getNumberOfEmptyCellsAtTheEndOfRow = counter 80 | End Function 81 | Function getNumberOfEmptyCellsAtTheStartOfRow(ByVal rngAsString As String, ByVal sheetname As String) As Integer 82 | With Worksheets(sheetname) 83 | Dim cellCount As Integer 84 | Dim rng As Range 85 | Set rng = .Range(rngAsString) 86 | cellCount = rng.Cells.Count 87 | Dim i As Integer 88 | Dim counter As Integer 89 | counter = 0 90 | For i = 1 To cellCount 91 | If rng.Cells(i) = vbNullString Then 92 | counter = counter + 1 93 | Else 94 | i = cellCount 95 | End If 96 | Next i 97 | End With 98 | getNumberOfEmptyCellsAtTheStartOfRow = counter 99 | End Function 100 | Function mergeCsvWithoutRepetition(ByVal csv1 As String, ByVal csv2) As String 101 | Dim result As String 102 | If csv1 = vbNullString Or csv2 = vbNullString Then 103 | result = csv1 & csv2 104 | Else 105 | Dim csvSplit1() As String 106 | csvSplit1 = Split(csv1, ",") 107 | Dim csvSplit2() As String 108 | csvSplit2 = Split(csv2, ",") 109 | Dim item As Variant 110 | 111 | 'get smallest csv to minimise additions to the other csv 112 | Dim csv1Count As Integer 113 | Dim csv2Count As Integer 114 | csv1Count = UBound(csvSplit1) - LBound(csvSplit1) + 1 115 | csv2Count = UBound(csvSplit2) - LBound(csvSplit2) + 1 116 | If csv1Count > 0 And csv1Count < csv2Count Then 117 | 'loop through smallest, non-empty csv 118 | For Each item In csvSplit1 119 | csv2 = addValueToCsvIfAbsent(csv2, item) 120 | Next item 121 | result = csv2 122 | Else 123 | 'loop through smallest, non-empty csv 124 | For Each item In csvSplit2 125 | csv1 = addValueToCsvIfAbsent(csv1, item) 126 | Next item 127 | result = csv1 128 | End If 129 | End If 130 | mergeCsvWithoutRepetition = Replace(result, ",,", ",") 131 | End Function 132 | Function addValueToCsvIfAbsent(ByVal csv_indicateLastValueWithoutCommaAtTheEnd As String, ByVal val As String) As String 133 | Dim result As String 134 | Dim arr() As String 135 | If csv_indicateLastValueWithoutCommaAtTheEnd = vbNullString Then 136 | result = val 137 | Else 138 | arr = Split(csv_indicateLastValueWithoutCommaAtTheEnd, ",") 139 | Dim s As Variant 140 | result = vbNullString 141 | For Each s In arr 142 | If result = vbNullString Then 143 | result = s 144 | Else 145 | If isDataInCSV(result, s) = False Then 146 | result = result & "," & s 147 | End If 148 | End If 149 | Next s 150 | 151 | If result = vbNullString Then 152 | result = val 153 | Else 154 | If isDataInCSV(result, val) = False Then 155 | result = result & "," & val 156 | End If 157 | End If 158 | End If 159 | addValueToCsvIfAbsent = result 160 | End Function 161 | Function isDataInCSV(ByVal csv_indicateLastValueWithoutCommaAtTheEnd As String, ByVal data As String) As Boolean 162 | Dim result As Boolean 163 | If csv_indicateLastValueWithoutCommaAtTheEnd = vbNullString Then 164 | result = False 165 | Else 166 | Dim csvSplit() As String 167 | csvSplit = Split(UCase(csv_indicateLastValueWithoutCommaAtTheEnd), ",") 168 | Dim v As Variant 169 | result = False 170 | data = UCase(data) 171 | For Each v In csvSplit 172 | If v = data Then 173 | result = True 174 | Exit For 175 | End If 176 | Next v 177 | End If 178 | isDataInCSV = result 179 | End Function 180 | Sub emptyThisRange(ByVal rngAsString As String, ByVal sheetname As String) 181 | Worksheets(sheetname).Range(rngAsString).ClearContents 182 | End Sub 183 | Function getColumnAsLetter(ByVal cellAddress As String) As String 184 | Dim addressSplit() As String 185 | If cellAddress <> vbNullString Then 186 | addressSplit = Split(cellAddress, "$") 187 | getColumnAsLetter = addressSplit(1) 188 | Else 189 | getColumnAsLetter = "" 190 | End If 191 | End Function 192 | Function lastRowNumOfNonEmptyCellInCol(ByVal firstRowNum As Integer, ByVal sheetname As String, ByVal column As String) As Integer 193 | Dim i As Integer 194 | i = firstRowNum 195 | Dim max As Integer 196 | With Worksheets(sheetname) 197 | Do Until i < 0 198 | If .Range(column & i) = vbNullString Then 199 | max = i - 1 200 | If max < firstRowNum Then 201 | max = firstRowNum 202 | End If 203 | i = -1 204 | Else 205 | i = i + 1 206 | End If 207 | Loop 208 | End With 209 | lastRowNumOfNonEmptyCellInCol = max 210 | End Function 211 | Function firstNonEmptyCell(ByVal sheetname As String, ByVal rangeAsString As String) As Range 212 | Dim cell As Range 213 | Dim r As Range 214 | Set r = Worksheets(sheetname).Range(rangeAsString) 215 | Dim i As Integer 216 | i = 1 217 | Dim result As Range 218 | For Each cell In r 219 | If cell.Value <> vbNullString And result Is Nothing Then 220 | Set result = cell 221 | Exit For 222 | End If 223 | Next cell 224 | Set firstNonEmptyCell = result 225 | End Function 226 | Function getColNum(ByVal letter As String) As Integer 227 | Dim r As Range 228 | Set r = Range(letter & "1") 229 | getColNum = r.column 230 | End Function 231 | Function lastNonEmptyCellAddressInTableRange(ByVal sheetname As String, ByVal tableRangeAsString As String) As String 232 | Dim table As Range 233 | Set table = Worksheets(sheetname).Range(tableRangeAsString) 234 | Dim cell As Range 235 | Dim result As Range 236 | For Each cell In table 237 | If cell.Value <> vbNullString Then 238 | Set result = cell 239 | End If 240 | Next cell 241 | lastNonEmptyCellAddressInTableRange = result.address 242 | End Function 243 | Sub emptyColumnAfterThisColumn(ByVal columnNum As Integer, ByVal r As Range) 244 | Dim c As Range 245 | For Each c In r 246 | If c.column > columnNum Then 247 | c.Value = vbNullString 248 | End If 249 | Next c 250 | End Sub 251 | Function arraySize(ByRef arr() As String) As Integer 252 | arraySize = UBound(arr) - LBound(arr) + 1 253 | End Function 254 | Function intArraySize(ByRef arr() As Integer) As Integer 255 | intArraySize = UBound(arr) - LBound(arr) + 1 256 | End Function 257 | Function lastNonEmptyCellAddressInRow(ByVal rangeAsStringOfRow As String, ByVal sheetname As String) As String 258 | With Worksheets(sheetname) 259 | Dim firstCell As Range 260 | Set firstCell = .Range(rangeAsStringOfRow) 261 | Dim firstColNum As Integer 262 | firstColNum = firstCell.column 263 | Dim lastCellAddress As String 264 | lastCellAddress = firstCell.address 265 | If InStr(firstCell.address, ":") Then 266 | lastCellAddress = Split(firstCell.address, ":")(0) 267 | Dim r As Range 268 | Set r = .Range(rangeAsStringOfRow) 269 | Dim cell As Range 270 | For Each cell In r 271 | If cell.Value <> vbNullString Then 272 | lastCellAddress = cell.address 273 | End If 274 | Next cell 275 | Else 276 | Dim i As Integer 277 | i = 1 278 | Do Until i < 0 279 | Dim c As Range 280 | Set c = .Range(Cells(firstCell.row, firstColNum + i), Cells(firstCell.row, firstColNum + i)) 281 | If c.Value <> vbNullString Then 282 | lastCellAddress = c.address 283 | i = i + 1 284 | Else 285 | i = -1 286 | End If 287 | Loop 288 | End If 289 | End With 290 | lastNonEmptyCellAddressInRow = lastCellAddress 291 | End Function 292 | Function doesRowExistInRange(ByVal rng As Range, ByVal rowAsRange As Range) As Boolean 293 | Dim rowInTbl As Range 294 | Dim finalResult As Boolean 295 | finalResult = False 296 | Dim lastRowNum As Integer 297 | Dim colCount As Integer 298 | colCount = rng.columns.Count 299 | For Each rowInTbl In rng.Rows 300 | Dim counter As Integer 301 | For counter = 1 To colCount 302 | If rowInTbl.Cells(counter) = rowAsRange.Cells(counter) Then 303 | If counter = colCount Then 304 | finalResult = True 305 | End If 306 | Else 307 | counter = colCount 308 | End If 309 | Next counter 310 | Next rowInTbl 311 | doesRowExistInRange = finalResult 312 | End Function 313 | Function doesRowExistInRange_whereRowISsProvidedAsACSV(ByVal rng As Range, ByVal rowAsCSV_indicateLastValueWithoutComma As String) As Boolean 314 | Dim rowInTbl As Range 315 | Dim finalResult As Boolean 316 | finalResult = False 317 | Dim lastRowNum As Integer 318 | Dim csvSplit() As String 319 | csv = Split(rowAsCSV_indicateLastValueWithoutComma, ",") 320 | Dim colCount As Integer 321 | colCount = rng.columns.Count 322 | For Each rowInTbl In rng.Rows 323 | Dim counter As Integer 324 | For counter = 1 To colCount 325 | If rowInTbl.Cells(counter) = csv(counter - 1) Then 326 | If counter = colCount Then 327 | finalResult = True 328 | End If 329 | Else 330 | counter = colCount 331 | End If 332 | Next counter 333 | If finalResult = True Then 334 | Exit For 335 | End If 336 | Next rowInTbl 337 | doesRowExistInRange_whereRowISsProvidedAsACSV = finalResult 338 | End Function 339 | Function rowToCSV(ByVal rowRange As Range) As String 340 | Dim result As String 341 | result = vbNullString 342 | Dim c As Range 343 | For Each c In rowRange.Cells 344 | If result <> vbNullString Then 345 | result = result & "," & c.Value 346 | Else 347 | result = c.Value 348 | End If 349 | Next c 350 | rowToCSV = result 351 | End Function 352 | -------------------------------------------------------------------------------- /DateFunctions.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "DateFunctions" 2 | 'Sonya - Date Functions 3 | 4 | Function getEarliestDate(ByVal sheetname As String, ByVal rangeAsString As String) As Date 5 | Dim rng As Range 6 | Set rng = Worksheets(sheetname).Range(rangeAsString) 7 | Dim cell As Range 8 | Dim result As Date 9 | result = CDate(rng(1).Value) 10 | For Each cell In rng 11 | If CDate(cell.Value) < result Then 12 | result = CDate(cell.Value) 13 | End If 14 | Next cell 15 | getEarliestDate = result 16 | End Function 17 | Function getLatestDate(ByVal sheetname As String, ByVal rangeAsString As String) As Date 18 | Dim rng As Range 19 | Set rng = Worksheets(sheetname).Range(rangeAsString) 20 | Dim cell As Range 21 | Dim result As Date 22 | result = CDate(rng(1).Value) 23 | For Each cell In rng 24 | If CDate(cell.Value) > result Then 25 | result = CDate(cell.Value) 26 | End If 27 | Next cell 28 | getLatestDate = result 29 | End Function 30 | Function getDayWithSuffix(ByVal d As Date) As String 31 | Dim dayStr As String 32 | dayStr = day(d) 33 | Dim found As Boolean 34 | found = False 35 | If CInt(dayStr) = "11" Or CInt(dayStr) = "12" Or CInt(dayStr) = "13" Then 36 | dayStr = dayStr & "th" 37 | found = True 38 | Else 39 | Dim number As String 40 | number = Mid(dayStr, Len(dayStr), 1) 41 | If number = "1" Then 42 | dayStr = dayStr & "st" 43 | found = True 44 | Else 45 | If number = "2" Then 46 | dayStr = dayStr & "nd" 47 | found = True 48 | Else 49 | If number = "3" Then 50 | dayStr = dayStr & "rd" 51 | found = True 52 | End If 53 | End If 54 | End If 55 | End If 56 | If found = False Then 57 | dayStr = dayStr & "th" 58 | End If 59 | getDayWithSuffix = dayStr 60 | End Function 61 | Function addZeroToHrOrMin(ByVal hourOrMin As Integer) As String 62 | addZeroToHrOrMin = hourOrMin 63 | If hourOrMin < 10 Then 64 | addZeroToHrOrMin = "0" & hourOrMin 65 | End If 66 | End Function 67 | -------------------------------------------------------------------------------- /ErrorDetection.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ErrorDetection" 2 | 'Sonya - Error Detection & Suggestion Feature 3 | 4 | Function getTyposAndSuggestions(ByVal userInputs As Range, ByVal options As Range, ByVal issue As String, ByVal sheetname As String, Optional ByVal nameColumn = "n/a") 5 | Dim anInput As String 6 | Dim anOption As String 7 | Dim i As Integer 8 | Dim j As Integer 9 | Dim iLimit As Integer 10 | Dim jLimit As Integer 11 | Dim results As String 12 | 13 | iLimit = userInputs.Count 14 | jLimit = options.Count 15 | With Worksheets(userInputs.Worksheet.name) 16 | For i = 1 To iLimit 17 | Dim selectedItem As Range 18 | Set selectedItem = userInputs(i) 19 | anInput = selectedItem.Value 20 | For j = 1 To jLimit 21 | anOption = options(j).Value 22 | 'if a mtach is found, the input is valid, move onto the next input 23 | If anInput = anOption Then 24 | j = jLimit + 1 25 | Else 26 | 'if input has been compared to all options, add it to the validation sheet 27 | If j = options.Count And anInput <> Empty Then 28 | results = getSuggestedValues(anInput, options) 29 | Dim issue2 As String 30 | issue2 = issue 31 | If nameColumn <> "n/a" Then 32 | issue2 = issue2 & " (" & .Range(nameColumn & selectedItem.row) & ")" 33 | End If 34 | Call updateValidationSheet(issue2, sheetname, selectedItem.address, anInput, results) 35 | results = vbNullString 36 | End If 37 | End If 38 | Next j 39 | Next i 40 | End With 41 | End Function 42 | Function getTyposAndSuggestions_multiSelect(ByVal userInputs As Range, ByVal options As Range, ByVal issue As String, ByVal sheetname As String, Optional ByVal nameColumn = "n/a", Optional ByVal delimeter = ";") 43 | Dim anInput As String 44 | Dim anOption As String 45 | Dim i As Integer 46 | Dim j As Integer 47 | Dim iLimit As Integer 48 | Dim jLimit As Integer 49 | Dim results As String 50 | 51 | iLimit = userInputs.Count 52 | jLimit = options.Count 53 | With Worksheets(userInputs.Worksheet.name) 54 | For i = 1 To iLimit 55 | Dim selectedItem As Range 56 | Set selectedItem = userInputs(i) 57 | anInput = selectedItem.Value 58 | Dim inputArray() As String 59 | inputArray = Split(anInput, delimeter) 60 | Dim str As Variant 61 | Dim position As Integer 62 | position = 0 63 | For Each str In inputArray 64 | position = position + 1 65 | For j = 1 To jLimit 66 | anOption = options(j).Value 67 | 'if a mtach is found, the input is valid, move onto the next input 68 | If str = anOption Then 69 | j = jLimit + 1 70 | Else 71 | 'if input has been compared to all options, add it to the validation sheet 72 | If j = options.Count And anInput <> Empty Then 73 | results = getSuggestedValues(str, options) 74 | Dim issue2 As String 75 | issue2 = issue 76 | If nameColumn <> "n/a" Then 77 | issue2 = issue2 & " - Entry at position " & position & " (" & .Range(nameColumn & selectedItem.row) & ")" 78 | End If 79 | Call updateValidationSheet(issue2, sheetname, selectedItem.address, anInput, results) 80 | results = vbNullString 81 | End If 82 | End If 83 | Next j 84 | Next str 85 | Next i 86 | End With 87 | End Function 88 | Function getSuggestedValues(ByVal key As String, ByVal rangeOfData As Range) As String 89 | Dim isAdvancedSearchOn As Boolean 90 | isAdvancedSearchOn = True 91 | Dim result As String 92 | result = vbNullString 93 | Dim cell As Range 94 | 'prevent case-sensitivity 95 | key = UCase(key) 96 | 'key length 97 | Dim keyLen As Integer 98 | keyLen = Len(key) 99 | 'get abbreviated key 100 | Dim abbr As String 101 | abbr = abbreviate(key) 102 | Dim abbrLen As Integer 103 | abbrLen = Len(abbr) 104 | For Each cell In rangeOfData 105 | 'prevent case-sesitivity 106 | word = UCase(cell.Value) 107 | Dim abbr_cell As String 108 | abbr_cell = abbreviate(word) 109 | If abbr = word Or abbr_cell = key Then 110 | result = result & word & ", " 111 | Else 112 | 'check if the key contains the word or vice versa; check if smaller string is contained in the bigger string as the reverse is impossible 113 | Dim big As String 114 | big = word 115 | Dim small As String 116 | small = key 117 | If keyLen > Len(word) Then 118 | big = key 119 | small = word 120 | End If 121 | If InStr(big, small) > 0 Then 122 | result = word & ", " 123 | isAdvancedSearchOn = False 124 | Else 125 | If isAdvancedSearchOn = True Then 126 | 'check if the key is an anagram of the word 127 | If is_Anagram(key, word, False) <> False Then 128 | result = result & word & ", " 129 | Else 130 | 'check if abbreviated key is an anagram of abbreviated word or whether abbreviated key is an anagram of the word 131 | If Len(abbr_cell) > 1 Then 132 | If is_Anagram(abbr, abbr_cell, False) <> False Then 133 | result = result & word & ", " 134 | End If 135 | End If 136 | End If 137 | End If 138 | End If 139 | End If 140 | Next cell 141 | getSuggestedValues = result 142 | End Function 143 | Function abbreviate(ByVal key As String) As String 144 | Dim abbr As String 145 | abbr = vbNullString 146 | If InStr(key, " ") = False Then 147 | abbr = Mid(key, 1, 1) 148 | Else 149 | 'split the keyword by space 150 | Dim keySplit() As String 151 | keySplit = Split(UCase(key), " ") 152 | Dim i As Integer 153 | Dim lenKeySplit As Integer 154 | lenKeySplit = UBound(keySplit) 155 | 'iterate through each item 156 | For i = 0 To lenKeySplit 157 | 'concatenate the first letter of each item 158 | abbr = abbr & Mid(keySplit(i), 1, 1) 159 | Next i 160 | End If 161 | abbreviate = abbr 162 | End Function 163 | Function is_Anagram(ByVal key As String, ByVal word As String, Optional ByVal exactMatch As Boolean = True) As Boolean 164 | Dim i As Integer 165 | Dim noOfRemainingChars As Integer 166 | Dim big As String 167 | Dim small As String 168 | Dim lenSmall As Integer 169 | Dim lenBig As Integer 170 | Dim lenKey As Integer 171 | Dim lenWord As Integer 172 | is_Anagram = False 173 | 174 | lenKey = Len(key) 175 | lenWord = Len(word) 176 | 177 | 'find out which has the least number of characters 178 | If lenKey > lenWord Then 179 | big = key 180 | small = word 181 | lenSmall = lenWord 182 | lenBig = lenKey 183 | Else 184 | big = word 185 | small = key 186 | lenSmall = lenKey 187 | lenBig = lenWord 188 | End If 189 | 190 | If lenBig = lenSmall Or lenBig = (lenSmall + 1) Then 191 | If exactMatch = True Then 192 | noOfRemainingChars = 0 193 | Else 194 | noOfRemainingChars = 1 195 | End If 196 | 'reducs number of loops by iterating through the shorter value 197 | For i = 1 To lenSmall 198 | Dim letter As String 199 | letter = Mid(small, i, 1) 200 | big = Replace(big, letter, "", Count:=1) 201 | Next i 202 | 203 | If Len(big) <= noOfRemainingChars Then 204 | is_Anagram = True 205 | Else 206 | is_Anagram = False 207 | End If 208 | End If 209 | End Function 210 | Function findExtremeValues(ByVal sheetname As String, ByVal rangeAsString As String, ByVal minimumVal As Integer, ByVal maxVal As Integer, Optional ByVal min_messageBeforeValue = "Extreme Value - Minimum value is ", Optional ByVal min_messageAfterValue = vbNullString, Optional ByVal max_messageBeforeValue = "Extreme Value - Maximum value is ", Optional ByVal max_messageAfterValue = vbNullString, Optional ByVal nameColumn = "n/a") As Integer 211 | Dim r As Range 212 | Dim cell As Range 213 | With Worksheets(sheetname) 214 | Set r = .Range(rangeAsString) 215 | Dim counter As Integer 216 | counter = 0 217 | For Each cell In r 218 | Dim name As String 219 | If cell.Value <> vbNullString Then 220 | If cell.Value < minimumVal Then 221 | If nameColumn <> "n/a" Then 222 | name = " (" & .Range(nameColumn & cell.row) & ")" 223 | End If 224 | Call updateValidationSheet(min_messageBeforeValue & minimumVal & min_messageAfterValue & " " & name, sheetname, cell.address, cell.Value, "") 225 | counter = counter + 1 226 | Else 227 | If cell.Value > maxVal Then 228 | If nameColumn <> "n/a" Then 229 | name = " (" & .Range(nameColumn & cell.row) & ")" 230 | End If 231 | Call updateValidationSheet(max_messageBeforeValue & maxVal & max_messageAfterValue & " " & name, sheetname, cell.address, cell.Value, "") 232 | counter = counter + 1 233 | End If 234 | End If 235 | End If 236 | Next cell 237 | End With 238 | findExtremeValues = counter 239 | End Function 240 | Function findExtremeValues_EntryDifferentToLookUp(ByVal lookupSheetname As String, ByVal lookupRange As String, ByVal minimumVal As Integer, ByVal maxVal As Integer, ByVal dataEntry_sheetname As String, ByVal dataEntry_range As String, Optional ByVal min_messageBeforeValue = "Extreme Value - Minimum value is ", Optional ByVal min_messageAfterValue = vbNullString, Optional ByVal max_messageBeforeValue = "Extreme Value - Maximum value is ", Optional ByVal max_messageAfterValue = vbNullString, Optional ByVal nameColumn = "n/a") As Integer 241 | Dim r As Range 242 | Dim dataEntryRange As Range 243 | Dim cell As Range 244 | With Worksheets(lookupSheetname) 245 | Set r = .Range(lookupRange) 246 | Set dataEntryRange = Worksheets(dataEntry_sheetname).Range(dataEntry_range) 247 | Dim counter As Integer 248 | Dim entryCell As Range 249 | counter = 0 250 | Dim cellCounter As Integer 251 | cellCounter = 1 252 | For Each cell In r 253 | Dim name As String 254 | If cell.Value <> vbNullString Then 255 | If cell.Value < minimumVal Then 256 | Set entryCell = dataEntryRange.Cells(cellCounter) 257 | If nameColumn <> "n/a" Then 258 | name = " (" & .Range(nameColumn & cell.row) & ")" 259 | End If 260 | Call updateValidationSheet(min_messageBeforeValue & minimumVal & min_messageAfterValue & " " & name, lookupSheetname, entryCell.address, entryCell.Value, "") 261 | counter = counter + 1 262 | Else 263 | If cell.Value > maxVal Then 264 | Set entryCell = dataEntryRange.Cells(cellCounter) 265 | If nameColumn <> "n/a" Then 266 | name = " (" & .Range(nameColumn & cell.row) & ")" 267 | End If 268 | Call updateValidationSheet(max_messageBeforeValue & maxVal & max_messageAfterValue & " " & name, lookupSheetname, entryCell.address, entryCell.Value, "") 269 | counter = counter + 1 270 | End If 271 | End If 272 | End If 273 | cellCounter = cellCounter + 1 274 | Next cell 275 | End With 276 | findExtremeValues_EntryDifferentToLookUp = counter 277 | End Function 278 | Function mandatoryChecksForCorrespondingCells(ByRef ranges() As Range, ByRef tblNames() As String, Optional ByVal nameColumn = "n/a") 279 | Dim i As Integer 280 | Dim j As Integer 281 | Dim k As Integer 282 | Dim rangCount As Integer 283 | rangCount = (UBound(ranges) - LBound(ranges)) - 1 284 | 285 | For i = 0 To rangCount 286 | Dim table As Range 287 | Set table = ranges(i) 288 | Dim cellCount As Integer 289 | cellCount = table.Cells.Count 290 | For j = 1 To cellCount 291 | Dim c As Range 292 | Set c = table.Cells(j) 293 | If c = vbNullString Then 294 | For k = 0 To rangCount 295 | If k <> i Then 296 | Dim table2 As Range 297 | Set table2 = ranges(k) 298 | Dim cell As Range 299 | Set cell = table2.Cells(j) 300 | If cell <> vbNullString Then 301 | Dim name As String 302 | If nameColumn <> "n/a" Then 303 | name = "(" & Worksheets(c.Worksheet.name).Range(nameColumn & c.row) & ")" 304 | End If 305 | Call updateValidationSheet("Missing Value in Correpsonding Cell - " & tblNames(i) & " " & name, table.Worksheet.name, c.address, c.Value, "", True) 306 | End If 307 | End If 308 | Next k 309 | End If 310 | Next j 311 | Next i 312 | End Function 313 | Function mandatoryChecksForCorrespondingCells_MsgBox(ByRef arr_ranges() As Range, ByRef tblNames() As String, ByVal sheetname As String, Optional ByVal colLetter_names As String = "n/a", Optional ByVal rowNum_headers As String = "n/a", Optional ByVal displayMsgBox = True) 314 | Dim i As Integer 315 | Dim j As Integer 316 | Dim table As Range 317 | Dim lboundArrRanges As Integer 318 | lboundArrRanges = LBound(arr_ranges) 319 | Dim uboundArrRanges As Integer 320 | uboundArrRanges = UBound(arr_ranges) - 1 321 | Dim result As String 322 | Dim messageCount As Integer 323 | messageCount = 0 324 | 325 | 'loop though ranges 326 | For i = lboundArrRanges To uboundArrRanges 327 | 'get table at position i 328 | Set table = arr_ranges(i) 329 | Dim col As Range 330 | 'track the column that is being looking at 331 | Dim column As Integer 332 | column = 0 333 | result = vbNullString 334 | 'loop though columns in table 335 | For Each col In table.columns 336 | 'increment column by 1 337 | column = column + 1 338 | Dim cell As Range 339 | 'keep track of the row that is being looked at 340 | Dim row As Integer 341 | row = 0 342 | 'loo through cells in column 343 | For Each cell In col.Cells 344 | 'increment row by 1 345 | row = row + 1 346 | 'check if the cell is blank 347 | If cell = vbNullString Then 348 | Dim table2 As Range 349 | 'loop through ranges 350 | For j = lboundArrRanges To uboundArrRanges 351 | 'get table at position j 352 | Set table2 = arr_ranges(j) 353 | 'prevent a table being compared to itself 354 | If table.address <> table2.address Then 355 | Dim cell2 As Range 356 | 'get cell at corresponding position 357 | Set cell2 = table2.Cells(row, column) 358 | 'check if the corresponding cell is not blank 359 | If cell2 <> vbNullString Then 360 | Dim label1 As String 361 | Dim label2 As String 362 | With Worksheets(sheetname) 363 | If colLetter_names <> "n/a" Then 364 | label1 = .Range(colLetter_names & cell.row) 365 | End If 366 | If rowNum_headers <> "n/a" Then 367 | label2 = .Range(getColumnAsLetter(cell.address) & rowNum_headers) 368 | End If 369 | End With 370 | 'add result to array 371 | If result = vbNullString Then 372 | result = "Missing information for " & tblNames(i) & " for " & ":" 373 | End If 374 | result = result & vbNewLine & label1 & " for " & label2 375 | 'once a non-empty corresponding cell is found, exit the loop to move onto the next row to prevent duplicate results 376 | j = uboundArrRanges 377 | End If 378 | End If 379 | Next j 380 | End If 381 | Next cell 382 | Next col 383 | If result <> vbNullString Then 384 | If displayMsgBox = True Then 385 | Call MsgBox(result) 386 | End If 387 | messageCount = messageCount + 1 388 | End If 389 | Next i 390 | mandatoryChecksForCorrespondingCells_MsgBox = messageCount 391 | End Function 392 | -------------------------------------------------------------------------------- /ExcelToSql_SolutionToUpdatingTheWebViaExcel.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SonyaNadesan/ReusablePerformanceOptimisedVBAFunctions/140a8483b172674de9b8045ef8d755a9ad75cc3f/ExcelToSql_SolutionToUpdatingTheWebViaExcel.xlsm -------------------------------------------------------------------------------- /MoveRangeFunctions.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "MoveRangeFunctions" 2 | 'Sonya - Move Ranges 3 | 4 | Sub shiftData_keepDataWithinRanges(ByVal sheetname As String, ByVal columnShift As Integer, ByRef tableRangesAsString() As String, Optional ByVal showConfirm = True) 5 | With Worksheets(sheetname) 6 | Dim warnUser As Boolean 7 | Dim allowShiftData As Boolean 8 | Dim subAddress As String 9 | Dim subTable As Range 10 | 11 | 'set default values 12 | warnUser = False 13 | allowShiftData = False 14 | Dim allowedShift As Integer 15 | Dim abs_columnShift As Integer 16 | 17 | 'check if confirmation is to be shown 18 | If showConfirm = True Then 19 | 'check if data will be lost; assign the result to variable which will be used to determine whether we will display warning message 20 | warnUser = willDataBeLost(tableRangesAsString, sheetname, columnShift) 21 | End If 22 | 23 | 'check whether the shift is to the left(-) or right(+) and store the number of shifts in a varible 24 | If columnShift < 0 Then 25 | abs_columnShift = columnShift * -1 26 | Else 27 | abs_columnShift = columnShift 28 | End If 29 | 30 | 'check if user is to be warned 31 | If warnUser = False Then 32 | Dim aRangeAsStr As Variant 33 | 'loop through the ranges 34 | For Each aRangeAsStr In tableRangesAsString 35 | If aRangeAsStr <> vbNullString Then 36 | 'shifting to the left 37 | If columnShift < 0 Then 38 | allowedShift = getNumberOfEmptyCellsAtTheStartOfRow(aRangeAsStr, sheetname) 39 | Else 40 | 'shifting to the right 41 | If columnShift > 0 Then 42 | allowedShift = getNumberOfEmptyCellsAtTheEndOfRow(aRangeAsStr, sheetname) 43 | End If 44 | End If 45 | subAddress = getSubTableWithinRange(aRangeAsStr, sheetname) 46 | If subAddress <> vbNullString Then 47 | Set subTable = .Range(subAddress) 48 | If allowedShift < abs_columnShift And columnShift > 0 Then 49 | Call emptyLastXcolumnsInRow(abs_columnShift - allowedShift, subAddress, sheetname) 50 | Else 51 | If allowedShift < abs_columnShift And columnShift < 0 Then 52 | Call emptyFirstXcolumnsInRow(abs_columnShift - allowedShift, subAddress, sheetname) 53 | End If 54 | End If 55 | subAddress = getSubTableWithinRange(aRangeAsStr, sheetname) 56 | Call shiftData(sheetname, subTable, columnShift, 0) 57 | End If 58 | End If 59 | Next aRangeAsStr 60 | Else 61 | If showConfirm = True Then 62 | If MsgBox("Warning: You may lose data. Would you like to proceed?", vbExclamation + vbYesNo) = vbYes Then 63 | allowShiftData = True 64 | Else 65 | allowShiftData = False 66 | End If 67 | Else 68 | allowShiftData = True 69 | End If 70 | If allowShiftData = True Then 71 | Dim aRangeAsStr2 As Variant 72 | For Each aRangeAsStr2 In tableRangesAsString 73 | If aRangeAsStr2 <> vbNullString Then 74 | If columnShift < 0 Then 75 | allowedShift = getNumberOfEmptyCellsAtTheStartOfRow(aRangeAsStr2, sheetname) 76 | Else 77 | If columnShift > 0 Then 78 | allowedShift = getNumberOfEmptyCellsAtTheEndOfRow(aRangeAsStr2, sheetname) 79 | End If 80 | End If 81 | subAddress = getSubTableWithinRange(aRangeAsStr2, sheetname) 82 | If subAddress <> vbNullString Then 83 | Set subTable = .Range(subAddress) 84 | If allowedShift < abs_columnShift And columnShift > 0 Then 85 | Call emptyLastXcolumnsInRow(abs_columnShift - allowedShift, subAddress, sheetname) 86 | Else 87 | If allowedShift < abs_columnShift And columnShift < 0 Then 88 | Call emptyFirstXcolumnsInRow(abs_columnShift - allowedShift, subAddress, sheetname) 89 | End If 90 | End If 91 | subAddress = getSubTableWithinRange(aRangeAsStr2, sheetname) 92 | If subAddress <> vbNullString Then 93 | Set subTable = .Range(subAddress) 94 | Call shiftData(sheetname, subTable, columnShift, 0) 95 | End If 96 | End If 97 | End If 98 | Next aRangeAsStr2 99 | End If 100 | End If 101 | End With 102 | End Sub 103 | Sub shiftData(ByVal sheetname As String, ByRef rng As Range, ByVal columnShift As Integer, ByVal rowShift As Integer) 104 | Worksheets(sheetname).Activate 105 | Dim noOfCells As Integer 106 | noOfCells = rng.Count 107 | Dim valuesInRng() As String 108 | ReDim valuesInRng(noOfCells) 109 | Dim cell As Range 110 | Dim i As Integer 111 | i = 0 112 | For Each cell In rng.Cells 113 | valuesInRng(i) = cell.Value 114 | cell.Value = "" 115 | i = i + 1 116 | Next cell 117 | Dim c As Range 118 | Dim j As Integer 119 | j = 0 120 | For Each c In rng 121 | Dim c2 As Integer 122 | Dim r2 As Integer 123 | c2 = c.column + columnShift 124 | r2 = c.row + rowShift 125 | If c2 > 0 And r2 > 0 Then 126 | If Worksheets(sheetname).Range(Cells(r2, c2), Cells(r2, c2)).AllowEdit = True Then 127 | Worksheets(sheetname).Range(Cells(r2, c2), Cells(r2, c2)).Value = valuesInRng(j) 128 | End If 129 | End If 130 | j = j + 1 131 | Next c 132 | End Sub 133 | 134 | Function getSubTableWithinRange(ByVal rangeAsString As String, ByVal sheetname As String) 135 | Dim firstCellAddress As String 136 | Dim lastCellAddress As String 137 | With Worksheets(sheetname) 138 | Dim r As Range 139 | Set r = .Range(rangeAsString) 140 | Dim c As Range 141 | Dim isFirstSet As Boolean 142 | isFirstSet = False 143 | For Each c In r 144 | If c.Value <> vbNullString And isFirstSet = False Then 145 | firstCellAddress = c.address 146 | isFirstSet = True 147 | Else 148 | If c.Value <> vbNullString And isFirstSet = True Then 149 | lastCellAddress = c.address 150 | End If 151 | End If 152 | Next c 153 | End With 154 | Dim result As String 155 | result = firstCellAddress & ":" & lastCellAddress 156 | If result = ":" Then 157 | result = "" 158 | Else 159 | If firstCellAddress <> vbNullString And lastCellAddress = vbNullString Then 160 | result = firstCellAddress & ":" & firstCellAddress 161 | End If 162 | End If 163 | getSubTableWithinRange = result 164 | End Function 165 | Function willDataBeLost(ByRef tableRangesAsString() As String, ByVal sheetname As String, ByVal columnShift As Integer) 166 | Dim result As Boolean 167 | result = False 168 | Dim str_range As Variant 169 | If columnShift > 0 Then 170 | For Each str_range In tableRangesAsString 171 | If str_range <> vbNullString Then 172 | If getNumberOfEmptyCellsAtTheEndOfRow(str_range, sheetname) < columnShift Then 173 | result = True 174 | Exit For 175 | End If 176 | End If 177 | Next str_range 178 | Else 179 | If columnShift < 0 Then 180 | Dim abs_columnShift As Integer 181 | abs_columnShift = columnShift * -1 182 | For Each str_range In tableRangesAsString 183 | If str_range <> vbNullString Then 184 | If getNumberOfEmptyCellsAtTheStartOfRow(str_range, sheetname) < abs_columnShift Then 185 | result = True 186 | Exit For 187 | End If 188 | End If 189 | Next str_range 190 | End If 191 | End If 192 | willDataBeLost = result 193 | End Function 194 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Complex, Re-Usable, Performance-Optimised VBA Functions (2017 - 2019) 2 | At GenSight, we provide software solutions to portfolio management for a range of clients including Johnson & Johnson, Pfizer, GSK and many more. As well as providing a highly configurable web application, we provide, two-way integration with Microsoft Excel, which has been proven to be very popular among finance professionals. 3 | 4 | These functions were developed during my time at GenSight, where I worked on the Project Financial Tool for Johnson & Johnson. 5 | These functions have been used in other Dynamic Documents such as Sales Entry, Capex and Investment Entry for the clients, Baxter and GSK, which saved development time. 6 | 7 | My second job since grduation was at a non-profit organisation, Marie Curie, where I got involved in many projects (mainly web apps). However, the fundraising team requested that they'd like to update fundraiser's information via a spreadsheet, and that any changes to this document, should indeed be reflected on their web pages. This involved writing some VBA and pointing out problems to this approach, including security, difficulty in maintainance as well as the lack of knowledge in the VBA progrramming language within the team. 8 | -------------------------------------------------------------------------------- /Sonya_VBA_Macros_Demo.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SonyaNadesan/ReusablePerformanceOptimisedVBAFunctions/140a8483b172674de9b8045ef8d755a9ad75cc3f/Sonya_VBA_Macros_Demo.xlsm -------------------------------------------------------------------------------- /UpdatingTheWebViaExcelSpreadsheet.docx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SonyaNadesan/ReusablePerformanceOptimisedVBAFunctions/140a8483b172674de9b8045ef8d755a9ad75cc3f/UpdatingTheWebViaExcelSpreadsheet.docx -------------------------------------------------------------------------------- /ValidationSheetFunctions.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ValidationSheetFunctions" 2 | 'Sonya - Validation Sheet 3 | 4 | Function updateValidationSheet(ByVal issue As String, ByVal sheetname As String, ByVal address As String, ByVal currentVal As String, ByVal suggestedvalues As String, Optional ByVal checkForDuplicatesBeforeUpdate = False) 5 | Dim row As Integer 6 | With Worksheets("Validation") 7 | row = .Range("B1").Value + 3 8 | Dim newRowAsCSV As String 9 | newRowAsCSV = issue & "," & sheetname & "," & address & "," & currentVal & "," & suggestedvalues 10 | If checkForDuplicatesBeforeUpdate = False Then 11 | Call addIssueToValidationSheet(row, issue, sheetname, address, currentVal, suggestedvalues) 12 | Else 13 | If doesRowExistInRange_whereRowISsProvidedAsACSV(.Range("A2:E" & (row - 1)), newRowAsCSV) = False Then 14 | Call addIssueToValidationSheet(row, issue, sheetname, address, currentVal, suggestedvalues) 15 | End If 16 | End If 17 | 'createNavigateButtonsInValidationSheet (Worksheets("Validation").Range("B1").Value) 18 | End With 19 | End Function 20 | Sub addIssueToValidationSheet(ByVal row As Integer, ByVal issue As String, ByVal sheetname As String, ByVal address As String, ByVal currentVal As String, ByVal suggestedvalues As String) 21 | With Worksheets("Validation") 22 | .Range("B1").Value = (row - 2) 23 | .Range("A" & row) = issue 24 | .Range("B" & row) = sheetname 25 | .Range("C" & row) = address 26 | If currentVal <> vbNullString Then 27 | .Range("D" & row) = currentVal 28 | End If 29 | If suggestedvalues <> vbNullString Then 30 | .Range("E" & row) = suggestedvalues 31 | End If 32 | End With 33 | End Sub 34 | Sub ClearIssuesInValidationSheet() 35 | With Worksheets("Validation") 36 | .Cells.ClearContents 37 | .Range("B1") = 0 38 | .Range("A1") = "No. Of Issues" 39 | .Range("A2") = "Validation Check Type" 40 | .Range("B2") = "Sheet" 41 | .Range("C2") = "Address" 42 | .Range("D2") = "Current Value" 43 | .Range("E2") = "Suggested Values" 44 | .Range("A2:D2").Interior.ColorIndex = 48 45 | End With 46 | End Sub 47 | Sub createNavigateButtonsInValidationSheet(ByVal noOfIssues As Integer) 48 | Application.ScreenUpdating = False 49 | Worksheets("Validation").Buttons.Delete 50 | Dim btn As Button 51 | For i = 3 To noOfIssues + 2 52 | Dim t As Range 53 | Set t = Range(Cells(i, 3), Cells(i, 3)) 54 | Set t = Worksheets("Validation").Range(t.address) 55 | If t.Value <> vbNullString Then 56 | Dim sheetname As String 57 | sheetname = Worksheets("Validation").Range("B" & i).Value 58 | Set btn = Worksheets("Validation").Buttons.add(t.Left, t.Top, t.Width, t.Height) 59 | With btn 60 | .OnAction = "NavigateToCell" 61 | .Caption = Replace(t.Value, "$", "") 62 | .name = sheetname & "!" & t.Value 63 | End With 64 | End If 65 | Next i 66 | End Sub 67 | Private Sub NavigateToCell() 68 | Dim cellRange As String 69 | cellRange = Application.Caller 70 | Dim data() As String 71 | data = Split(cellRange, "!") 72 | ThisWorkbook.Sheets(data(0)).Activate 73 | Range(data(1)).Select 74 | End Sub 75 | --------------------------------------------------------------------------------