├── .gitignore ├── ZipCodeAndCountyMappingDataPub.xlsx ├── LICENSE ├── README.md └── UtilsPub.bas /.gitignore: -------------------------------------------------------------------------------- 1 | Utils.bas -------------------------------------------------------------------------------- /ZipCodeAndCountyMappingDataPub.xlsx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nathanhere/Excel-VBA-Data-Functions/HEAD/ZipCodeAndCountyMappingDataPub.xlsx -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2019 nathanhere 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Excel Logo Banner](https://www.versionmuseum.com/images/applications/microsoft-excel/microsoft-excel%5E2016%5Eexcel-logo-new.png) 2 | 3 | Excel VBA Functions Package for Business Data Analysts 4 | === 5 | Created to facilitate data processing and analysis at the business operations level. Common functions used for Excel-based projects / reports / apps requiring extensive data manipulation. 6 | 7 | Drag and drop the .bas file as a module in the VBA editor. 8 | 9 | Requires a basic understanding of how to use functions within VBA. For an overview, please visit http://www.excel-vba-easy.com/vba-programming-function-sub.html or http://www.excelfunctions.net/VBA-Functions-And-Subroutines.html. 10 | 11 | Note that most functions included in this package require a worksheet object as the first argument. 12 | 13 | ### Example using the lastRow function: ### 14 | 15 | If the last row of data is located on row 15, this routine will select cells A1:C15 16 | ```vba 17 | Set ws = workbooks("currentOpenWorkbook.xlsx").worksheets("Sheet1") 18 | ws.cells(lastRow(ws),3).select 19 | ``` 20 | Where `lastRow(ws)` returns the **last row number** of worksheet **ws**, and **`3`** is Column C (the third column in a worksheet). 21 | 22 | Please feel free to contact me for any help/clarification. 23 | 24 | # License # 25 | 26 | This software is available under the MIT license. 27 | -------------------------------------------------------------------------------- /UtilsPub.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Utils" 2 | 3 | '************************************************************************** 4 | '********************* FUNCTIONS PACKAGE *********************************** 5 | '************************************************************************** 6 | '# Version 2.3.7 7 | '# All functions are assumed to be compatible with non .xls formats only 8 | 9 | '# Updated on 8/1/2012 - Added new parameter on lastColNum function 10 | '# Updated on 7/12/2012 - lastColNum function - Revised to use a loop as the primary last row detection mechanism instead of lastUsedCol built in function (was causing too many problems) 11 | '# Updated on 7/9/2012: Refactored getMonthNameAndYear function to use built-in Format function instead of a dictionary structure (Thanks to Randal B!) 12 | ' Updated move_entries to make the move of the header row as optional 13 | '# Updated on 7/3/2012: Added vbaLookup2 function. Many times faster than vbalookup, and exponentially faster than vlookup. See function for more details. 14 | 15 | 16 | Public Declare Function GetTickCount Lib "kernel32.dll" () As Long '// 17 | 18 | '************************************************************************** 19 | Public Function isxls(ByVal ws As Worksheet) As Boolean 20 | '// Tests to see whether a given worksheet is in the old excel format. 21 | '// Authored by Nathan N on 7/6/2012 22 | 23 | If Right(ws.Name, 4) = ".xls" Then isxls = True 24 | 25 | End Function 26 | Public Sub trim_data_fields(ByVal ws As Worksheet, ByVal fieldName As String) 27 | '// Authored by Nathan N on 6/21/2012 28 | 29 | Dim i As Long 30 | 31 | For i = 2 To lastRow(ws) 32 | ws.Cells(i, FieldColNum(ws, fieldName)) = Trim(ws.Cells(i, FieldColNum(ws, fieldName))) 33 | Next i 34 | 35 | End Sub 36 | Public Sub move_all_entries(ByVal wsSource As Worksheet, ByVal wsDest As Worksheet) 37 | '// Authored by Nathan N on 6/28/2012 38 | '// Moves all data from one worksheet to another. Strips all data of any previous formatting as well. 39 | '// Assumes that data has no 'pre headers' in the first few rows 40 | 41 | wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(lastRow(wsSource), lastColNum(wsSource))) = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow(wsSource), lastColNum(wsSource))).value 42 | 43 | End Sub 44 | Public Sub mergeWorksheets(ByVal wsSource As Worksheet, ByVal wsDest As Worksheet, ByVal sourceKey As String, ByVal destKey As String) 45 | '// Authored by Nathan N on 1/14/2015 46 | '// Merges all fields of a source worksheet into a destination worksheet 47 | '// sourceKey must be located in column 1 (or col "A") 48 | 49 | Dim sourceColCount As Integer, destColCount As Integer 50 | Dim destFieldName As String 51 | Dim i As Long, j As Long 52 | 53 | sourceColCount = lastColNum(wsSource) 54 | destColCount = lastColNum(wsDest) 55 | 56 | If wsSource.Cells(1, 1) <> sourceKey Then 57 | MsgBox ("SourceKey is not located in column 1 of the Source worksheet! Quitting mergeWorksheets routine!") 58 | Exit Sub 59 | End If 60 | Application.ScreenUpdating = False 61 | 62 | For i = 1 To sourceColCount 63 | If wsSource.Cells(1, i) = sourceKey Then GoTo NextColumn 64 | '//destColNum = destColCount + i 65 | destFieldName = wsSource.Cells(1, i) 66 | vbaLookup2 wsDest, destFieldName, destKey, wsSource, sourceKey, destFieldName, , , , , , True 67 | NextColumn: 68 | Next i 69 | 70 | Application.ScreenUpdating = True 71 | 72 | 73 | End Sub 74 | Public Sub getMonthNameAndYear(ByVal ws As Worksheet, ByVal dateField As Worksheet, newDateFieldName As String) 75 | '// Inserts a condensed month name and year based on the original date field 76 | '// Added 7/2/2012 by Nathan N 77 | '// Updated 7/9/2012: Refactored function to use built-in Format function instead of a dictionary structure (Thanks to Randal B!) 78 | 79 | Dim dateColNum As Integer, monthColNum As Integer 80 | Dim dateColLet As String 81 | Dim dateValue As Date, monthValue As Integer, yearValue As Integer, fullMonthName As String 82 | Dim newDateValue As String 83 | Dim i As Long 84 | 85 | Application.ScreenUpdating = False 86 | 87 | Set ws = ActiveWorkbook.ActiveSheet 88 | dateColLet = InputBox("Enter the Date Column Letter:") 89 | 90 | Application.ScreenUpdating = False 91 | 92 | dateColNum = LetToColNum(dateColLet) 93 | monthColNum = dateColNum + 1 94 | ws.Columns(monthColNum).Insert 95 | ws.Columns(monthColNum).NumberFormat = "@" 96 | ws.Cells(1, monthColNum) = "Month" 97 | 98 | For i = 2 To lastRow(ws) 99 | dateValue = ws.Cells(i, dateColNum) 100 | newDateValue = Format(dateValue, "mmm yyyy") 101 | ws.Cells(i, monthColNum) = newDateValue 102 | Next i 103 | 104 | Application.ScreenUpdating = True 105 | 106 | End Sub 107 | Public Sub move_entries(ByVal wsSource As Worksheet, ByVal wsDest As Worksheet, ByVal fieldName As String, ByVal keywordInFieldName As String, Optional ByVal copyHeader As Boolean, Optional ByVal deleteMovedEntries As Boolean) 108 | Dim startRow As Long, endRow As Long, startRowDest As Long, endRowDest As Long 109 | '// Moves larges swathes of entries to a destination sheet quickly and as values (removes all formatting) 110 | '// Authored by Nathan N on 6/28/2012 111 | '// Updated 'itemToMove' to 'keywordInFieldName' 112 | '// Updated on 7/9/2012 to make the copy over of the Header row as optional (header row is assumed to be located on row 1) 113 | Application.ScreenUpdating = False 114 | 115 | SortCol wsSource, fieldName 116 | startRow = FieldRowNum(wsSource, keywordInFieldName, FieldColNum(wsSource, fieldName)) 117 | endRow = FieldRowNum(wsSource, keywordInFieldName, FieldColNum(wsSource, fieldName), , , , True) 118 | 119 | If startRow = 0 Then '// if no matching keywordInFieldName was found then function exits 120 | Debug.Print "Function move_entries: keywordInFieldName was not found. No entries moved." 121 | Exit Sub 122 | End If 123 | 124 | If copyHeader = True Then wsDest.Rows(1) = wsSource.Rows(1).value 125 | 126 | startRowDest = lastRow(wsDest) + 1 127 | endRowDest = endRow - startRow + startRowDest 128 | wsDest.Range(wsDest.Cells(startRowDest, 1), wsDest.Cells(endRowDest, lastColNum(wsSource))) = wsSource.Range(wsSource.Cells(startRow, 1), wsSource.Cells(endRow, lastColNum(wsSource))).value 129 | 130 | If deleteMovedEntries = True Then wsSource.Rows(startRow & ":" & endRow).Delete 131 | 132 | End Sub 133 | Public Sub convert_string_to_int(ByVal ws As Worksheet, ByVal zipcodeFieldName As String) 134 | '// Authored by Nathan N on 7/5/2012 135 | '// Converts numbers that are in string format to int 136 | 137 | Dim i As Long 138 | Dim zipColNum As Integer 139 | 140 | On Error Resume Next 141 | 142 | zipColNum = FieldColNum(ws, zipcodeFieldName) 143 | 144 | For i = 2 To lastRow(ws, , FieldColNum(ws, zipcodeFieldName)) 145 | ws.Cells(i, zipColNum) = Int(ws.Cells(i, zipColNum)) 146 | Next i 147 | 148 | On Error GoTo 0 149 | 150 | End Sub 151 | Public Sub zipcode_county_lookup_manual() '(ByVal ws As Worksheet, ByVal zipcodeFieldName As String, Optional ByVal stateFieldName As String, Optional ByVal singleStateName As String, Optional ByVal listStates As Boolean) 152 | '// Matches zip codes with county names in worksheets with multiple states listed 153 | '// Authored by Nathan N on 6/26/2012 154 | 155 | Dim wb As Workbook, ws As Worksheet, wbCounty As Workbook, wsCounty As Worksheet, wsState As Worksheet 156 | Dim state As String, zipCode As Long 157 | Dim colLet As String 158 | Dim zipColLet As String, zipColNum As Integer, countyColNum As Integer, stateColNum As Integer 159 | Dim zipToCountyMappingPath As String 160 | Dim rngCounty As Range 161 | Dim stateFieldName As String, zipcodeFieldName As String, singleStateName As String, listStates As Boolean 162 | Dim i As Long 163 | 164 | Application.DisplayAlerts = False 165 | Application.ScreenUpdating = False 166 | 167 | zipToCountyMappingPath = file_reference_path() & "\ZipCodeAndCountyMappingDataPub.xlsx" 168 | 169 | Set wb = ActiveWorkbook 170 | Set ws = wb.ActiveSheet 171 | 172 | If Right(wb.Name, 4) = ".xls" Then 173 | MsgBox (FirstName() & ", it looks like you're using a workbook that's saved in the old excel format." & vbCrLf & vbCrLf & "Please resave your workbook as an .xlsx format. Then close and reopen.") 174 | Exit Sub 175 | End If 176 | 177 | '// Attempt to auto detect the zip code column 178 | zipColNum = FieldColNum(ws, "zip", , True) 179 | If zipColNum = 0 Then zipColNum = FieldColNum(ws, "zip c", , True) 180 | If zipColNum = 0 Then zipColNum = FieldColNum(ws, "zip_c", , True) 181 | If zipColNum = 0 Then zipColNum = FieldColNum(ws, "zip_", , True) 182 | If zipColNum = 0 Then zipColNum = FieldColNum(ws, "zip", , True) 183 | If zipColNum = 0 Then 184 | zipColLet = InputBox("Enter the zip code column letter:") 185 | zipColNum = LetToColNum(zipColLet) 186 | End If 187 | 188 | '// This corrects data for which zip codes are listed as Strings on a work sheet instead of int. String data types will cause the vbalookup function to not find the zip codes. 189 | zipcodeFieldName = ws.Cells(1, zipColNum) 190 | 191 | convert_string_to_int ws, zipcodeFieldName 192 | 193 | countyColNum = zipColNum + 1 194 | 195 | If zipColNum = -1 Then 196 | Debug.Print ("Error: zipcode_county_lookup function. Zip Code Column could not be located. Ended function.") 197 | Exit Sub 198 | End If 199 | 200 | If Not (FieldExists(ws, "County")) Then 201 | ws.Columns(countyColNum).Insert 202 | ws.Cells(1, countyColNum) = "County" 203 | countyColNum = FieldColNum(ws, "County") 204 | End If 205 | 206 | If stateFieldName = "" And singleStateName = "" Then 207 | stateColNum = FieldColNum(ws, "state", , True) 208 | ElseIf stateFieldName <> "" And singleStateName = "" Then 209 | stateColNum = FieldColNum(ws, stateFieldName, , True) 210 | ElseIf stateFieldName = "" And singleStateName <> "" Then 211 | state = singleStateName 212 | stateColNum = 0 213 | End If 214 | ' 215 | 'If listStates = True Then 216 | ' If FieldExists(ws, "State") Then 217 | ' Debug.Print "State Field Already Exists. Please Delete before continuing." 218 | ' Exit Sub 219 | ' End If 220 | ' ws.Columns(countyColNum + 1).Insert 221 | ' ws.Cells(1, countyColNum + 1) = "State" 222 | 'End If 223 | stateColNum = -1 224 | If stateColNum = -1 Then '//If no state field was found or listed, the program assumes that we are to search all states to match counties 225 | 226 | If Not (FieldExists(ws, "State")) Then 227 | ws.Cells(1, countyColNum + 1) = "State" 228 | ws.Columns(countyColNum + 1).Insert 229 | End If 230 | 231 | listStates = True 232 | Set wbCounty = Workbooks.Open(zipToCountyMappingPath, , True) 233 | Set wsState = wbCounty.Worksheets.Add 234 | wsState.Move , wbCounty.Worksheets(wbCounty.Worksheets.Count) 235 | wsState.Cells(1, 1) = "Zip Code" 236 | wsState.Cells(1, 2) = "City Name" 237 | wsState.Cells(1, 3) = "State" 238 | wsState.Cells(1, 4) = "Primary County Name" 239 | 240 | For Each wss In wbCounty.Worksheets 241 | If wss.Name = wsState.Name Then Exit For 242 | wsState.Range(wsState.Cells(lastRow(wsState) + 1, 1), wsState.Cells(lastRow(wsState) - 1 + lastRow(wss), 4)) = wss.Range(wss.Cells(2, 1), wss.Cells(lastRow(wss), 4)).value 243 | Next wss 244 | 245 | Set wsCounty = wsState 246 | 247 | VbaZipLookup ws, "County", zipcodeFieldName, wsCounty, "ZIP Code", "Primary County Name", listStates 248 | 249 | '// Check for unmatched items 250 | For i = 2 To lastRow(ws) 251 | Set rngCounty = ws.Cells(i, FieldColNum(ws, "County")) 252 | zipCode = ws.Cells(i, FieldColNum(ws, zipcodeFieldName)) 253 | If rngCounty.value = "" Then rngCounty.value = "0 Not Found" 254 | Next i 255 | 256 | Debug.Print ("Used All State Information because State Column could not originally be located.") 257 | wbCounty.Close 258 | Application.DisplayAlerts = True 259 | Application.ScreenUpdating = True 260 | MsgBox (FirstName() & ", the counties have been added to your data." & vbCrLf & vbcrl & "-Report Robot") 261 | Exit Sub 262 | 263 | End If 264 | 265 | '// If a valid state field name was provided, then the program limits the scope to only states that are listed 266 | Set wbCounty = Workbooks.Open(zipToCountyMappingPath, , True) 267 | ws.Activate 268 | 269 | If singleStateName = "" Then 270 | 271 | For i = 2 To lastRow(ws) 272 | Set rngCounty = ws.Cells(i, FieldColNum(ws, "County")) 273 | 274 | If stateColNum > 0 Then state = ws.Cells(i, stateColNum) 275 | zipCode = ws.Cells(i, FieldColNum(ws, zipcodeFieldName)) 276 | On Error GoTo errhandler 277 | Set wsCounty = wbCounty.Worksheets(state) 278 | rngCounty.value = wsCounty.Cells(Application.WorksheetFunction.Match(zipCode, wsCounty.Columns(FieldColNum(wsCounty, "ZIP Code")), 0), FieldColNum(wsCounty, "Primary County Name")) 279 | On Error GoTo 0 280 | NextZipCode: 281 | Next i 282 | Else 283 | Set wsCounty = wbCounty.Worksheets(singleStateName) 284 | For i = 2 To lastRow(ws) 285 | Set rngCounty = ws.Cells(i, FieldColNum(ws, "County")) 286 | zipCode = ws.Cells(i, FieldColNum(ws, zipcodeFieldName)) 287 | On Error GoTo ErrHandler2 288 | rngCounty.value = wsCounty.Cells(Application.WorksheetFunction.Match(zipCode, wsCounty.Columns(FieldColNum(wsCounty, "ZIP Code")), 0), FieldColNum(wsCounty, "Primary County Name")) 289 | On Error GoTo 0 290 | NextZipCode2: 291 | Next i 292 | 293 | End If 294 | wbCounty.Close 295 | Exit Sub 296 | 297 | errhandler: 298 | Err.Clear 299 | rngCounty.value = "0 Not Found" 300 | Resume NextZipCode 301 | 302 | ErrHandler2: 303 | Err.Clear 304 | rngCounty.value = "0 Not Found" 305 | Resume NextZipCode2 306 | 307 | End Sub 308 | 309 | Public Sub zipcode_county_lookup(ByVal ws As Worksheet, ByVal zipcodeFieldName As String, Optional ByVal stateFieldName As String, Optional ByVal singleStateName As String, Optional ByVal listStates As Boolean) 310 | '// Matches zip codes with county names in worksheets with multiple states listed 311 | '// Authored by Nathan N on 6/11/2012 312 | '// Updated 6/14/2012 - compiles all state zip code information if no state is listed 313 | 314 | Dim wbCounty As Workbook, wsCounty As Worksheet, wsState As Worksheet 315 | Dim wb As Workbook 316 | Dim state As String, zipCode As Long 317 | Dim rngCounty As Range 318 | Dim colLet As String 319 | Dim zipColNum As Integer, countyColNum As Integer, stateColNum As Integer 320 | Dim zipToCountyMappingPath As String 321 | 322 | Dim i As Long 323 | 324 | Application.DisplayAlerts = False 325 | 326 | zipToCountyMappingPath = file_reference_path() & "\ZipCodeAndCountyMappingDataPub.xlsx" 327 | 328 | zipColNum = FieldColNum(ws, zipcodeFieldName, , True) 329 | countyColNum = zipColNum + 1 330 | 331 | If zipColNum = -1 Then 332 | Debug.Print ("Error: zipcode_county_lookup function. Zip Code Column could not be located. Ended function.") 333 | Exit Sub 334 | End If 335 | 336 | ws.Columns(countyColNum).Insert 337 | ws.Cells(1, countyColNum) = "County" 338 | 339 | If stateFieldName = "" And singleStateName = "" Then 340 | stateColNum = FieldColNum(ws, "state", , True) 341 | ElseIf stateFieldName <> "" And singleStateName = "" Then 342 | stateColNum = FieldColNum(ws, stateFieldName, , True) 343 | ElseIf stateFieldName = "" And singleStateName <> "" Then 344 | state = singleStateName 345 | stateColNum = 0 346 | End If 347 | ' 348 | 'If listStates = True Then 349 | ' If FieldExists(ws, "State") Then 350 | ' Debug.Print "State Field Already Exists. Please Delete before continuing." 351 | ' Exit Sub 352 | ' End If 353 | ' ws.Columns(countyColNum + 1).Insert 354 | ' ws.Cells(1, countyColNum + 1) = "State" 355 | 'End If 356 | 357 | If stateColNum = -1 Then '//If no state field was found or listed, the program assumes that we are to search all states to match counties 358 | ws.Columns(countyColNum + 1).Insert 359 | ws.Cells(1, countyColNum + 1) = "State" 360 | listStates = True 361 | Set wbCounty = Workbooks.Open(zipToCountyMappingPath, , True) 362 | Set wsState = wbCounty.Worksheets.Add 363 | wsState.Move , wbCounty.Worksheets(wbCounty.Worksheets.Count) 364 | wsState.Cells(1, 1) = "Zip Code" 365 | wsState.Cells(1, 2) = "City Name" 366 | wsState.Cells(1, 3) = "State" 367 | wsState.Cells(1, 4) = "Primary County Name" 368 | 369 | For Each wss In wbCounty.Worksheets 370 | If wss.Name = wsState.Name Then Exit For 371 | wsState.Range(wsState.Cells(lastRow(wsState) + 1, 1), wsState.Cells(lastRow(wsState) - 1 + lastRow(wss), 4)) = wss.Range(wss.Cells(2, 1), wss.Cells(lastRow(wss), 4)).value 372 | Next wss 373 | 374 | Set wsCounty = wsState 375 | 376 | VbaZipLookup ws, "County", zipcodeFieldName, wsCounty, "ZIP Code", "Primary County Name", listStates 377 | 378 | '// Check for unmatched items 379 | For i = 2 To lastRow(ws) 380 | Set rngCounty = ws.Cells(i, FieldColNum(ws, "County")) 381 | zipCode = ws.Cells(i, FieldColNum(ws, zipcodeFieldName)) 382 | If rngCounty.value = "" Then rngCounty.value = zipCode & " Not Found" 383 | Next i 384 | 385 | Debug.Print ("Used All State Information because State Column could not originally be located.") 386 | wbCounty.Close 387 | Exit Sub 388 | 389 | End If 390 | 391 | '// If a valid state field name was provided, then the program limits the scope to only states that are listed 392 | Set wbCounty = Workbooks.Open(zipToCountyMappingPath, , True) 393 | ws.Activate 394 | 395 | If singleStateName = "" Then 396 | 397 | For i = 2 To lastRow(ws) 398 | Set rngCounty = ws.Cells(i, FieldColNum(ws, "County")) 399 | 400 | If stateColNum > 0 Then state = ws.Cells(i, stateColNum) 401 | zipCode = ws.Cells(i, FieldColNum(ws, zipcodeFieldName)) 402 | On Error GoTo errhandler 403 | Set wsCounty = wbCounty.Worksheets(state) 404 | rngCounty.value = wsCounty.Cells(Application.WorksheetFunction.Match(zipCode, wsCounty.Columns(FieldColNum(wsCounty, "ZIP Code")), 0), FieldColNum(wsCounty, "Primary County Name")) 405 | On Error GoTo 0 406 | NextZipCode: 407 | Next i 408 | Else 409 | Set wsCounty = wbCounty.Worksheets(singleStateName) 410 | For i = 2 To lastRow(ws) 411 | Set rngCounty = ws.Cells(i, FieldColNum(ws, "County")) 412 | zipCode = ws.Cells(i, FieldColNum(ws, zipcodeFieldName)) 413 | On Error GoTo ErrHandler2 414 | rngCounty.value = wsCounty.Cells(Application.WorksheetFunction.Match(zipCode, wsCounty.Columns(FieldColNum(wsCounty, "ZIP Code")), 0), FieldColNum(wsCounty, "Primary County Name")) 415 | On Error GoTo 0 416 | NextZipCode2: 417 | Next i 418 | 419 | End If 420 | wbCounty.Close 421 | Exit Sub 422 | 423 | errhandler: 424 | Err.Clear 425 | rngCounty.value = "0 Not Found" 426 | Resume NextZipCode 427 | 428 | ErrHandler2: 429 | Err.Clear 430 | rngCounty.value = "0 Not Found" 431 | Resume NextZipCode2 432 | 433 | End Sub 434 | Public Sub zipcode_state_lookup(ByVal ws As Worksheet, ByVal zipcodeFieldName As String) 435 | '// Authored by Nathan N on 6/11/2012 436 | '// Updated 6/14/2012 - compiles all state zip code information if no state is listed 437 | '// Matches zip codes with county names in worksheets with multiple states listed 438 | Dim wbCounty As Workbook, wsCounty As Worksheet, wsState As Worksheet 439 | Dim wb As Workbook 440 | Dim state As String, zipCode As Long 441 | Dim rngCounty As Range 442 | Dim colLet As String 443 | Dim stateColNum As Integer, zipColNum As Integer 444 | Dim i As Long 445 | 446 | zipColNum = FieldColNum(ws, zipcodeFieldName, , True) 447 | stateColNum = zipColNum + 1 448 | 449 | If zipColNum = -1 Then 450 | Debug.Print ("Error: zipcode_county_lookup function. Zip Code Column could not be located. Ended function.") 451 | Exit Sub 452 | End If 453 | 454 | ws.Columns(stateColNum).Insert 455 | ws.Cells(1, stateColNum) = "State" 456 | 457 | Set wbCounty = Workbooks.Open(file_reference_path() & "\ZipCodeAndCountyMappingDataPub.xlsx", , True) 458 | Set wsState = wbCounty.Worksheets.Add 459 | wsState.Move , wbCounty.Worksheets(wbCounty.Worksheets.Count) 460 | wsState.Cells(1, 1) = "Zip Code" 461 | wsState.Cells(1, 2) = "City Name" 462 | wsState.Cells(1, 3) = "State" 463 | wsState.Cells(1, 4) = "Primary County Name" 464 | 465 | For Each wss In wbCounty.Worksheets 466 | If wss.Name = wsState.Name Then Exit For 467 | wsState.Range(wsState.Cells(lastRow(wsState) + 1, 1), wsState.Cells(lastRow(wsState) - 1 + lastRow(wss), 4)) = wss.Range(wss.Cells(2, 1), wss.Cells(lastRow(wss), 4)).value 468 | Next wss 469 | 470 | Set wsCounty = wsState 471 | 472 | vbaLookup ws, "State", zipcodeFieldName, wsCounty, "ZIP Code", "State" 473 | 474 | '// Check for unmatched items 475 | For i = 2 To lastRow(ws) 476 | Set rngCounty = ws.Cells(i, FieldColNum(ws, "State")) 477 | zipCode = ws.Cells(i, FieldColNum(ws, zipcodeFieldName)) 478 | If rngCounty.value = "" Then rngCounty.value = zipCode & " Not Found" 479 | Next i 480 | 481 | wbCounty.Close 482 | 483 | End Sub 484 | Public Function sigPath() As String 485 | '// Authored by Nathan N on 6/6/2012 486 | '// Returns the email signature path for the user 487 | 488 | If windows7os() Then 489 | sigPath = user_root(True) & "\AppData\Roaming\Microsoft\Signatures" 490 | Else 491 | sigPath = user_root(True) & "\Application Data\Microsoft\Signatures" 492 | End If 493 | 494 | End Function 495 | Public Function user_root(Optional ByVal excludeMyDocuments As Boolean) As String 496 | Dim docPath As String 497 | '* Authored by Nathan N on 6/4/2012 498 | '* Modified 6/6/2012 499 | '* Returns the Path to windows 7 user's "My Documents" folder 500 | '* If excludeMyDocuments = true, the function returns the path only up to the UserName folder 501 | If excludeMyDocuments = False Then docPath = "\My Documents" 502 | 503 | If windows7os() = True Then 504 | If docPath <> "" Then 505 | docPath = "\" & Right(docPath, Len(docPath) - 4) 506 | user_root = "C:\Users\" & loginName() & docPath 507 | Else 508 | user_root = "C:\Users\" & loginName() 509 | End If 510 | Else 511 | user_root = "C:\Documents and Settings\" & loginName() & docPath 512 | End If 513 | 514 | End Function 515 | Public Function windows7os() As Boolean 516 | '* Authored by Nathan N on 6/4/2012 517 | '* Determines if user is using windows 7 518 | 519 | If Left(Application.OperatingSystem, 21) = "Windows (32-bit) NT 5" Then 520 | windows7os = False 521 | Else 522 | windows7os = True 523 | End If 524 | 525 | End Function 526 | Public Function hub_path() As String 527 | '// Created by Nathan N on 7/9/2012 528 | hub_path = "\\hqclienthub\Client Hub" 529 | End Function 530 | Public Function file_reference_path() As String 531 | '// Created by Nathan N on 7/9/2012 532 | '// Helper function used avoid using long absolute file paths for common file resources 533 | '// You must specify the path within the quotations below. 534 | file_reference_path = "" 535 | End Function 536 | 537 | Public Sub delete_empty_entries(ByVal ws As Worksheet, ByVal fieldName As String) 538 | 'Authored by Nathan N on 4/9/2012 539 | 540 | Dim i As Long 541 | 542 | For i = 2 To lastRow(ws) 543 | 544 | If (ws.Cells(i, FieldColNum(ws, fieldName)) = "") Then 545 | ws.Rows(i).Delete Shift:=xlUp 546 | i = i - 1 547 | If (i = lastRow(ws)) Then 548 | Exit For 549 | End If 550 | End If 551 | 552 | Next i 553 | 554 | End Sub 555 | Public Sub AggregateServices(ByVal ws As Worksheet, ByVal WOFieldName As String, ByVal serviceFieldName As String, ByVal newFieldName As String, Optional ByVal sortBeforehand As Boolean) 556 | '*** Created on 3/20/2012 by Nathan N *** 557 | '*** Combines services on seperate row entries into one line for the same work order number*** 558 | '*** User needs to remove duplicate work orders seperately *** 559 | 560 | Dim currentWO As String 561 | Dim aggServiceType As String, newServiceType As String 562 | Dim WOCol As Integer, currentServiceCol As Integer, newServiceCol As Integer 563 | Dim i As Long, j As Long 564 | 565 | WOCol = FieldColNum(ws, WOFieldName) 566 | currentServiceCol = FieldColNum(ws, serviceFieldName) 567 | newServiceCol = lastColNum(ws) + 1 568 | ws.Cells(1, newServiceCol) = newFieldName 569 | 570 | If sortBeforehand = True Then SortMultiCol ws, ws.Cells(1, WOCol), ws.Cells(1, currentServiceCol) 571 | 572 | For i = 2 To lastRow(ws) 573 | 574 | currentWO = ws.Cells(i, WOCol) 575 | aggServiceType = "" 576 | 577 | For j = i To lastRow(ws) 578 | 579 | If currentWO = ws.Cells(j, WOCol) Then 580 | newServiceType = ws.Cells(j, currentServiceCol) 581 | aggServiceType = aggServiceType & ", " & newServiceType 582 | End If 583 | 584 | If currentWO <> ws.Cells(j + 1, WOCol) Then 585 | ws.Cells(i, newServiceCol) = aggServiceType 586 | If j >= lastRow(ws) Then 587 | ws.Cells(i, newServiceCol) = aggServiceType 588 | '// Last Row error correction 589 | ws.Cells(lastRow(ws), newServiceCol) = Right(ws.Cells(lastRow(ws), newServiceCol), Len(ws.Cells(lastRow(ws), newServiceCol)) - 2) 590 | Exit Sub 591 | End If 592 | If (Len(ws.Cells(i, newServiceCol)) > 0) Then 593 | ws.Cells(i, newServiceCol) = Right(ws.Cells(i, newServiceCol), Len(aggServiceType) - 2) 594 | End If 595 | i = j 596 | GoTo nextWO 597 | End If 598 | 599 | Next j 600 | 601 | nextWO: 602 | 603 | Next i 604 | 605 | End Sub 606 | Public Function InArray(ByRef arrayName() As Variant, ByVal elementValue As Variant) As Boolean 607 | 'Created on 3/13/2012 by Nathan N 608 | 609 | Dim i As Long 610 | 611 | For i = 0 To UBound(arrayName()) 612 | If (elementValue = arrayName(i)) Then 'If the elementValue is found at any point in the array, then TRUE 613 | InArray = True 614 | Exit Function 615 | End If 616 | Next i 617 | 618 | 619 | InArray = False 'Otherwise, InArray is false 620 | 621 | End Function 622 | 623 | Public Function DateStamp(Optional AMPM As Boolean, Optional dateOnly As Boolean, Optional AMPMDateStamp As Boolean, Optional AMPMTimeStamp As Boolean) As String 624 | '*************************************************** 625 | '**** created by Nathan N on 1/25/2012 **** 626 | 'Updated on 3/9/2012 to correct for the extra space in the AMPMTimeStamp 627 | 628 | Dim timeStamp As String, timeStampAMPM As String, AMPMAndDateStamp As String 629 | 630 | If dateOnly = True Then 631 | DateStamp = Date 632 | DateStamp = Replace(DateStamp, "/", " ") 633 | Exit Function 634 | End If 635 | 636 | If AMPM = True Then 637 | timeStamp = Time() 638 | timeStamp = Replace(timeStamp, ":", " ") 639 | timeStamp = Left(Trim(timeStamp), 2) 640 | timeStampAMPM = Time() 641 | timeStampAMPM = Right(Trim(Now()), 2) 642 | DateStamp = timeStampAMPM 643 | Exit Function 644 | End If 645 | 646 | If AMPMTimeStamp = True Then 647 | DateStamp = Date 648 | DateStamp = Replace(DateStamp, "/", " ") 649 | timeStamp = Time() 650 | timeStamp = Replace(timeStamp, ":", " ") 651 | timeStamp = Replace(Left(Trim(timeStamp), 2), " ", "") 652 | timeStampAMPM = Time() 653 | timeStampAMPM = Right(Trim(Now()), 2) 654 | AMPMAndDateStamp = timeStampAMPM & " - " & DateStamp 655 | timeAndDateStamp = timeStamp & " " & timeStampAMPM & " - " & DateStamp 656 | DateStamp = timeAndDateStamp 657 | Exit Function 658 | End If 659 | 660 | If AMPMDateStamp = True Then 661 | DateStamp = Date 662 | DateStamp = Replace(DateStamp, "/", " ") 663 | timeStamp = Time() 664 | timeStamp = Replace(timeStamp, ":", " ") 665 | timeStamp = Left(Trim(timeStamp), 2) 666 | timeStampAMPM = Time() 667 | timeStampAMPM = Right(Trim(Now()), 2) 668 | AMPMAndDateStamp = timeStampAMPM & " - " & DateStamp 669 | DateStamp = AMPMAndDateStamp 670 | Exit Function 671 | End If 672 | 673 | End Function 674 | Public Sub CleanServiceName(ByVal ws As Worksheet, ByVal serviceColNum As Integer) 675 | '*** 3/6/2012 *** 676 | Dim i As Long 677 | Dim serviceName As String 678 | 679 | For i = 2 To lastRow(ws) 680 | 681 | serviceName = LCase(ws.Cells(i, serviceColNum)) 682 | 683 | If (serviceName Like "*recut*") Or (serviceName Like "*lawn*") Then 684 | ws.Cells(i, serviceColNum) = "Ongoing Recut" 685 | ElseIf serviceName Like "*maid*" Then 686 | ws.Cells(i, serviceColNum) = "Ongoing Maid" 687 | ElseIf serviceName Like "*pool*" Then 688 | ws.Cells(i, serviceColNum) = "Ongoing Pool" 689 | ElseIf serviceName Like "*snow*" Then 690 | ws.Cells(i, serviceColNum) = "Ongoing Snow" 691 | End If 692 | 693 | Next i 694 | 695 | End Sub 696 | Public Sub CopyMultiValRows(sourceSheet As Worksheet, colLet As String, destSheet As Worksheet, copyValues As String, Optional copyHeader As Boolean) 697 | Dim inverseRow As Long 698 | Dim lastRowCurrent As Long 699 | Dim lastRowDest As Long 700 | Dim i As Long 701 | 702 | 703 | If copyHeader <> False Then 704 | copyHeader = True 705 | End If 706 | 707 | lastRowCurrent = sourceSheet.Range("A" & Rows.Count).End(xlUp).Row 708 | origRowCount = sourceSheet.Range("A" & Rows.Count).End(xlUp).Row 709 | 710 | If copyHeader = True Then 711 | destSheet.Rows(1) = sourceSheet.Rows(1).value 712 | lastRowDest = destSheet.Range("A" & Rows.Count).End(xlUp).Row 713 | End If 714 | 715 | For i = 2 To lastRowCurrent 716 | inverseRowNum = origRowCount - i + 2 717 | currentCellValue = sourceSheet.Range(colLet & inverseRowNum).value 718 | 719 | If InStr(1, copyValues, currentCellValue) >= 1 Then 720 | destSheet.Rows(lastRowDest + 1) = sourceSheet.Rows(inverseRowNum).value 721 | lastRowDest = destSheet.Range("A" & Rows.Count).End(xlUp).Row 722 | End If 723 | 724 | Next i 725 | 726 | End Sub 727 | 728 | Sub CutMultiValRows(ByVal sourceSheet As Worksheet, ByVal colLet As String, ByVal destSheet As Worksheet, ByVal cutValues As String, Optional copyHeader As Boolean) 729 | Dim inverseRow As Long 730 | Dim lastRow As Long 731 | Dim lastRowDest As Long 732 | Dim i As Long 733 | 734 | If copyHeader = "" Then 735 | copyHeader = True 736 | End If 737 | 738 | lastRow = sourceSheet.Range(colLet & Rows.Count).End(xlUp).Row 739 | origRowCount = sourceSheet.Range(colLet & Rows.Count).End(xlUp).Row 740 | 741 | If copyHeader = True Then 742 | destSheet.Rows(1) = sourceSheet.Rows(1).value 743 | lastRowDest = destSheet.Range("A" & Rows.Count).End(xlUp).Row 744 | End If 745 | 746 | For i = 2 To lastRow 747 | inverseRowNum = origRowCount - i + 2 748 | currentCellValue = sourceSheet.Range(colLet & inverseRowNum).value 749 | 750 | If InStr(1, cutValues, currentCellValue) >= 1 Then 751 | destSheet.Rows(lastRowDest + 1) = sourceSheet.Rows(inverseRowNum).value 752 | lastRowDest = destSheet.Range("A" & Rows.Count).End(xlUp).Row 753 | sourceSheet.Rows(inverseRowNum).Delete Shift:=xlUp 754 | End If 755 | 756 | Next i 757 | 758 | End Sub 759 | Public Sub SortCol(ByVal ws As Worksheet, ByVal fieldName As String, Optional ByVal headerRowNum As Integer) 760 | '********************************************************* 761 | '*** Authored by Nathan N, on 1/18/2012 762 | '*** 763 | '*** Updateed on 2/1/2012 at 11:19AM - Switched from function to sub 764 | '*** Updated on 2/3/2012 at 1:00PM - Switched out sortColNum parameter with fieldname:string 765 | '*** - Removed the application.visible property and implemented a Wait method 766 | 767 | '********************************************************* 768 | Dim sortColNum As Integer 769 | 770 | sortColNum = FieldColNum(ws, fieldName) 771 | 772 | If headerRowNum = 0 Then 773 | headerRowNum = 1 774 | End If 775 | 776 | ws.Activate 777 | ws.Sort.SortFields.Clear 778 | ws.Sort.SortFields.Add ws.Cells(headerRowNum, sortColNum) 779 | ws.Sort.Header = xlNo 780 | ws.Sort.MatchCase = False 781 | ws.Sort.SetRange ws.Range(Cells(headerRowNum + 1, 1), Cells(lastRow(ws), lastColNum(ws))) 782 | 'Application.Visible = True 783 | Application.Wait Now + 0.000008 784 | 785 | ws.Sort.Apply 786 | 'Application.Visible = False 787 | 788 | 789 | End Sub 790 | 791 | Public Sub SortMultiCol(ByVal ws As Worksheet, ByVal fieldName1 As String, Optional ByVal fieldName2 As String, Optional ByVal fieldName3 As String, Optional ByVal headerRowNum As Integer) 792 | '********************************************************* 793 | '*** Authored by Nathan N, on 2/27/2012 794 | '*** Updated 2/28/2012 8:17AM - Added functionality for 3 columns to be sorted 795 | '********************************************************* 796 | Dim sortColNum1 As Integer, sortColNum2 As Integer 797 | 798 | sortColNum1 = FieldColNum(ws, fieldName1) 799 | 800 | If (FieldExists(ws, fieldName2)) And (fieldName2 <> "") Then 801 | sortColNum2 = FieldColNum(ws, fieldName2) 802 | End If 803 | If FieldExists(ws, fieldName3) And (fieldName3 <> "") Then 804 | sortColNum3 = FieldColNum(ws, fieldName3) 805 | End If 806 | 807 | If headerRowNum = 0 Then headerRowNum = 1 808 | 809 | ws.Activate 810 | ws.Sort.SortFields.Clear 811 | ws.Sort.SortFields.Add ws.Cells(headerRowNum, sortColNum1) 812 | 813 | If FieldExists(ws, fieldName2) And (fieldName2 <> "") Then ws.Sort.SortFields.Add ws.Cells(headerRowNum, sortColNum2) 814 | 815 | If FieldExists(ws, fieldName3) And (fieldName3 <> "") Then ws.Sort.SortFields.Add ws.Cells(headerRowNum, sortColNum3) 816 | 817 | ws.Sort.Header = xlNo 818 | ws.Sort.MatchCase = False 819 | ws.Sort.SetRange ws.Range(Cells(headerRowNum + 1, 1), Cells(lastRow(ws), lastColNum(ws))) 820 | 'Application.Visible = True 821 | Application.Wait Now + 0.000008 '// This is needed in order for the function to work successfully 822 | ws.Sort.Apply 823 | 'Application.Visible = False 824 | 825 | End Sub 826 | Public Sub remove_dupes(ByVal ws As Worksheet, ByVal fieldName As String) 827 | '// Created on 5/3/2012 by Nathan N 828 | 829 | Dim colNum As Integer 830 | 831 | colNum = FieldColNum(ws, fieldName) 832 | 833 | ws.Range(ws.Cells(1, 1), ws.Cells(lastRow(ws), lastColNum(ws))).RemoveDuplicates Columns:=colNum, Header:=xlYes 834 | 835 | End Sub 836 | Public Function lastRow(ByVal ws As Worksheet, Optional ByVal colLet As String, Optional ByVal colNum As Integer, Optional ByVal startRow As Long) As Long 837 | '********************************************************* 838 | '*** Authored by Nathan N, on 1/13/2012 839 | '*** Updated 3/2/2012 - Added startRow functionality to find last rows of irregular data 840 | '*** Updated 6/13/2012 - Added conditional block that took into account if a ColNum greater than 0 was used. 841 | '*** Optional [colLet] parameter takes precedence over Optional [colNum] 842 | '*** Detects the last row with data in a specified column letter 843 | '*** PreCondition: 1. At least one worksheet row must have data 844 | '*** 2. Optional: A specific column letter can be declared. 845 | '*** If no column letter is declared, function will default 846 | '*** to the "A" column 847 | '*** PostCondition: Returns a number (Long type) 848 | '*** Updated 3/9/2012 - included IF statement for colNum = 1 and startRow = 1 849 | '*** Updated 4/3/2012 - Corrected bug that ended up adding one to the last row if the startRow>0 850 | '********************************************************* 851 | 852 | If colLet = "" And colNum = 0 Then colLet = "A" 853 | 854 | If colLet <> "" And startRow = 0 Then 855 | lastRow = ws.Range(colLet & Rows.Count).End(xlUp).Row 856 | Exit Function 857 | End If 858 | 859 | If colLet = "" And colNum > 0 And startRow = 0 Then 860 | lastRow = ws.Cells(Rows.Count, colNum).End(xlUp).Row 861 | Exit Function 862 | End If 863 | 864 | If (colNum = 0) Then colNum = 1 865 | If (startRow = 0) Then startRow = 1 866 | 867 | If colNum = 1 And startRow = 1 Then 868 | lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row 869 | Exit Function 870 | End If 871 | 872 | If startRow > 0 Then 873 | 874 | For i = startRow To 500000 875 | 876 | If ws.Cells(i, colNum) = "" Then 877 | lastRow = i - 1 878 | Exit Function 879 | End If 880 | 881 | Next i 882 | 883 | End If 884 | 885 | End Function 886 | Public Function lastColNum(ByVal ws As Worksheet, Optional ByVal rowNum As Long = 1, Optional ByVal ignoreBreaks As Boolean = False) As Integer 887 | '********************************************************* 888 | '*** Authored byNathan N, on 1/13/2012 889 | '*** Updated 6/13/2012 - Added Optional [rowNum] parameter to detect lastCol of a specific row 890 | '*** This detects the last column number 891 | '*** PreCondition: At least one column needs to be used on a worksheet 892 | '*** PostCondition: Returns an integer of the last most column number 893 | '*** that has data 894 | '// Updated 7/12/2012 - Revised to use a loop as the primary last row detection mechanism instead of lastUsedCol built in function (was causing too many problems) 895 | '// Updated 8/1/2012 - included optional ignoreBreaks parameter 896 | '********************************************************* 897 | Dim i As Integer 898 | 899 | If ignoreBreaks Then 900 | lastColNum = ws.UsedRange.Columns.Count 901 | Exit Function 902 | End If 903 | 904 | For i = 1 To ws.UsedRange.Columns.Count + 1 905 | If ws.Cells(rowNum, i) = "" Then 906 | lastColNum = i - 1 907 | Exit For 908 | End If 909 | Next i 910 | 911 | If lastColNum = 0 Then lastColNum = ws.UsedRange.Columns.Count 912 | 913 | End Function 914 | Public Function LastColtoLet(ByVal currentSheet As Worksheet) As String 915 | '********************************************************* 916 | '*** Authored by Nathan N, on 1/13/2012 917 | '*** 918 | '*** This returns the letter of an automatically detected last column number 919 | '*** PreCondition: 1. A specific worksheet name must be declared 920 | '*** 2. At least one column must have data within the column 921 | '*** range of A to Z 922 | '*** 923 | '*** PostCondition: Returns the letter (String Type) that was associated with 924 | '*** the detected last column 925 | '********************************************************* 926 | Dim letArray() As Variant 927 | Dim maxArrayCount As Long 928 | Dim lastCol As Integer 929 | ReDim letArray(0 To 100) 930 | 931 | '--- More letters can be added to the letArray(0 to 25) to extend functionality, however 932 | '--- the letArray must be redimensioned with more elements to match the 933 | '--- quantity of letters listed. For instance, if "AA", "AB","AC" were added to letArray, 934 | '--- we must redimension the letArray with the following: ReDim letArray(0 to 28) 935 | 936 | letArray = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE", "BF") 937 | 938 | maxArrayCount = (Application.WorksheetFunction.CountA(letArray)) 939 | ReDim Preserve letArray(0 To maxArrayCount - 1) 940 | 941 | lastCol = currentSheet.UsedRange.Columns.Count 942 | 943 | LastColtoLet = letArray(lastCol - 1) 944 | 945 | End Function 946 | Public Function LetToColNum(ByVal s As String) As Integer 947 | '********************************************************* 948 | '*** Authored by Nathan N, on 3/20/2012 949 | '*** 950 | '*** This returns the Col Num of a specified Col Let, up to BF 951 | 952 | '********************************************************* 953 | Dim letArray() As Variant 954 | Dim maxArrayCount As Long 955 | ReDim letArray(0 To 100) 956 | 957 | letArray = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE", "BF") 958 | maxArrayCount = (Application.WorksheetFunction.CountA(letArray)) 959 | ReDim Preserve letArray(0 To maxArrayCount - 1) 960 | 961 | For i = 0 To maxArrayCount 962 | If UCase(s) = letArray(i) Then 963 | LetToColNum = i + 1 964 | Exit Function 965 | End If 966 | Next i 967 | 968 | End Function 969 | Public Function ColNumToLet(ByVal currentSheet As Worksheet, ByVal colNum As Integer) As String 970 | '********************************************************* 971 | '*** Authored by Nathan N, on 1/13/2012 972 | '*** 973 | '*** This returns the letter of an automatically detected last column number 974 | '*** PreCondition: 1. A specific worksheet name must be declared 975 | '*** 2. At least one column must have data within the column 976 | '*** range of A to Z 977 | '*** 978 | '*** PostCondition: Returns the letter (String Type) that was associated with 979 | '*** the detected last column 980 | '********************************************************* 981 | Dim letArray() As Variant 982 | Dim maxArrayCount As Long 983 | 984 | ReDim letArray(0 To 100) 985 | '--- More letters can be added to the letArray(0 to 25) to extend functionality, however 986 | '--- the letArray must be redimensioned with more elements to match the 987 | '--- quantity of letters listed. For instance, if "AA", "AB","AC" were added to letArray, 988 | '--- we must redimension the letArray with the following: ReDim letArray(0 to 28) 989 | 990 | letArray = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE", "BF") 991 | maxArrayCount = (Application.WorksheetFunction.CountA(letArray)) 992 | ReDim Preserve letArray(0 To maxArrayCount - 1) 993 | 994 | 'colNum = currentSheet.UsedRange.Columns.Count 995 | 996 | ColNumToLet = letArray(colNum - 1) 997 | 998 | End Function 999 | Public Function FieldColLet(ByVal currentSheet As Worksheet, ByVal fieldName As String, Optional ByVal rowNum As Integer) As String 1000 | '********************************************************* 1001 | '*** Authored by Nathan N, on 1/18/2012 1002 | '*** 1003 | '*** This returns the column letter of a specified field name 1004 | '*** PreCondition: 1. A specific worksheet name must be declared 1005 | '*** 2. At least one column must have data within the column 1006 | '*** range of A to AZ 1007 | '*** 3. if rowNum is not specified, then default is 1 1008 | '*** 1009 | '*** PostCondition: Returns the col letter (String Type) that was associated with 1010 | '*** the fieldName. 1011 | '*** 1012 | '********************************************************* 1013 | Dim letArray() As Variant 1014 | Dim FieldColNum As Integer 1015 | Dim maxArrayCount As Long 1016 | 1017 | ReDim letArray(0 To 100) 1018 | '--- More letters can be added to the letArray(0 to 25) to extend functionality, however 1019 | '--- the letArray must be redimensioned with more elements to match the 1020 | '--- quantity of letters listed. For instance, if "AA", "AB","AC" were added to letArray, 1021 | '--- we must redimension the letArray with the following: ReDim letArray(0 to 28) 1022 | If rowNum = 0 Then rowNum = 1 1023 | 1024 | letArray = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE", "BF", "BG", "BH") 1025 | maxArrayCount = (Application.WorksheetFunction.CountA(letArray)) 1026 | ReDim Preserve letArray(0 To maxArrayCount - 1) 1027 | 1028 | FieldColNum = Application.WorksheetFunction.Match(fieldName, currentSheet.Rows(rowNum), 0) 1029 | FieldColLet = letArray(FieldColNum - 1) 1030 | 1031 | End Function 1032 | Public Function FieldColNum(ByVal ws As Worksheet, ByVal fieldName As String, Optional ByVal rowNum As Long, Optional approxMatch As Boolean) As Integer 1033 | '********************************************************* 1034 | '*** Authored by Nathan N, on 1/18/2012 1035 | '***Updated on 1/31/2012 - Added For i loop that addresses field names with spaces 1036 | '***Updated on 3/5/2012 - Changed rowNum type to Long from Ingeter 1037 | '***Updated on 6/12/2012 - Added optional approxMatch boolean and functionality 1038 | '*** - Returns -1 upon failure 1039 | '*** 1040 | '*** This returns the column letter of a specified field name 1041 | '*** PreCondition: 1. A specific worksheet name must be declared 1042 | '*** 2. A valid fieldName must be declared and located on the 1043 | '*** specified rowNum. If no rowNum is specified, then default 1044 | '*** is 1. 1045 | '*** PostCondition: Returns a column number 1046 | '*** 1047 | '*** 1048 | '********************************************************* 1049 | Dim i As Long 1050 | 1051 | If rowNum = 0 Then rowNum = 1 1052 | 1053 | If approxMatch = True Then 1054 | 1055 | For i = 1 To lastColNum(ws) 1056 | If LCase(ws.Cells(rowNum, i)) Like "*" & LCase(fieldName) & "*" Then 1057 | FieldColNum = i 1058 | Exit Function 1059 | End If 1060 | Next i 1061 | 1062 | End If 1063 | 1064 | If InStr(1, " ", fieldName) Then 'This takes into account the two different types of data spreadsheet formats (One that has spaces inbetween field names, and one that has no spaces) 1065 | 1066 | For i = 1 To lastColNum(ws) 1067 | If ws.Cells(rowNum, i) = fieldName Then 1068 | FieldColNum = i 1069 | Exit Function 1070 | End If 1071 | Next i 1072 | 1073 | Else 1074 | On Error Resume Next 1075 | FieldColNum = Application.WorksheetFunction.Match(fieldName, ws.Rows(rowNum), 0) 1076 | If (FieldColNum = 0) Then FieldColNum = Application.WorksheetFunction.Match(CInt(fieldName), ws.Rows(rowNum), 0) 1077 | If (FieldColNum = 0) Then FieldColNum = Application.WorksheetFunction.Match(CDec(fieldName), ws.Rows(rowNum), 0) 1078 | If (FieldColNum = 0) Then '// If the function fails, return -1 1079 | FieldColNum = -1 1080 | Exit Function 1081 | End If 1082 | On Error GoTo 0 1083 | End If 1084 | 1085 | End Function 1086 | Public Function outline_cells(ByVal rng As Range) 1087 | 'Authored by Nathan N on 4/6/2012 1088 | 1089 | With rng.Borders(xlEdgeLeft) 1090 | .LineStyle = xlContinuous 1091 | .ColorIndex = 0 1092 | .TintAndShade = 0 1093 | .Weight = xlThin 1094 | End With 1095 | With rng.Borders(xlEdgeTop) 1096 | .LineStyle = xlContinuous 1097 | .ColorIndex = 0 1098 | .TintAndShade = 0 1099 | .Weight = xlThin 1100 | End With 1101 | With rng.Borders(xlEdgeBottom) 1102 | .LineStyle = xlContinuous 1103 | .ColorIndex = 0 1104 | .TintAndShade = 0 1105 | .Weight = xlThin 1106 | End With 1107 | With rng.Borders(xlEdgeRight) 1108 | .LineStyle = xlContinuous 1109 | .ColorIndex = 0 1110 | .TintAndShade = 0 1111 | .Weight = xlThin 1112 | End With 1113 | With rng.Borders(xlInsideVertical) 1114 | .LineStyle = xlContinuous 1115 | .ColorIndex = 0 1116 | .TintAndShade = 0 1117 | .Weight = xlThin 1118 | End With 1119 | With rng.Borders(xlInsideHorizontal) 1120 | .LineStyle = xlContinuous 1121 | .ColorIndex = 0 1122 | .TintAndShade = 0 1123 | .Weight = xlThin 1124 | End With 1125 | 1126 | End Function 1127 | Public Function FieldRowNum(ByVal ws As Worksheet, ByVal fieldName As String, Optional ByVal colNum As Integer, Optional ByVal colLet As String, Optional startRowNum As Long, Optional ByVal fromTop As Boolean, Optional ByVal fromBottom As Boolean, Optional exactMatch As Boolean) As Long 1128 | 1129 | '*** Authored by Nathan N on 2/1/2012 *** 1130 | '*** Finds the row number for the first found instance of the specified fieldName:string, from the top of the data or the bottom 1131 | '*** Updated 2/21/2012 at 1:30PM - Added Exact Match parameter 1132 | '*** Updated 2/27/2012 at 3:49PM - Fixed the "From Bottom" functionality 1133 | '*** Updated 3/2/2012 at 1:35PM - Defaulted to fromTop = true if neither fromTop or fromBottom were selected 1134 | '*** Updated 3/15/2012 at 1:44PM - Corrected issue whereby the search would start from the top, even if specified to start from the bottom 1135 | ' when the colNum was 0 or empty 1136 | Dim fieldFound As Boolean 1137 | Dim rowNum As Long 1138 | Dim i As Long, inverseRowNum As Long 1139 | 1140 | If (fromTop = False And fromBottom = False) Then 1141 | fromTop = True 1142 | End If 1143 | 1144 | If (exactMatch = False) Then 1145 | If (fromTop = True) Or (fromTop = False And fromBottom = False) Then 1146 | If (colNum <> 0) Then 1147 | If startRowNum = 0 Then 1148 | startRowNum = 1 1149 | End If 1150 | 1151 | For i = startRowNum To lastRow(ws, , colNum) 1152 | 1153 | If (InStr(1, LCase(ws.Cells(i, colNum)), LCase(fieldName)) > 0) Then 1154 | FieldRowNum = i 1155 | 'Debug.Print "SUCCESS: FieldRowNum function found the string """ & fieldName & """ in row " & i & ", column number " & colNum & "." 1156 | Exit Function 1157 | End If 1158 | 1159 | Next i 1160 | 1161 | 'Debug.Print "WARNING: FieldRowNum function did not find the string """ & fieldName & """ in column number " & colNum & "." 1162 | Exit Function 1163 | End If 1164 | 1165 | If colNum = 0 Then 1166 | If startRowNum = 0 Then 1167 | startRowNum = 1 1168 | End If 1169 | For i = startRowNum To lastRow(ws) 1170 | 1171 | If (InStr(1, LCase(ws.Cells(i, 1)), LCase(fieldName)) > 0) Then 1172 | FieldRowNum = i 1173 | 'Debug.Print "SUCCESS: FieldRowNum function found the string """ & fieldName & """ in row " & i & ", column number " & colNum & "." 1174 | Exit Function 1175 | End If 1176 | 1177 | Next i 1178 | 'Debug.Print "SUCCESS: FieldRowNum function found the string """ & fieldName & """ in row " & rowNum & ", column number " & colNum & "." 1179 | Exit Function 1180 | End If 1181 | 1182 | 'Debug.Print "WARNING: FieldRowNum function did not find the string """ & fieldName & """ in column number " & colNum & "." 1183 | Exit Function 1184 | End If 1185 | 1186 | If (fromBottom = True) Then 1187 | 1188 | If (colNum = 0) Then colNum = 1 1189 | 1190 | If startRowNum = 0 Then startRowNum = lastRow(ws) 1191 | 1192 | origRowCount = lastRow(ws) 1193 | 1194 | For i = 1 To startRowNum 1195 | inverseRowNum = startRowNum - i + 1 1196 | 1197 | If (InStr(1, LCase(ws.Cells(inverseRowNum, colNum)), LCase(fieldName)) > 0) Then 'This currently only supports approx match 1198 | FieldRowNum = inverseRowNum 1199 | 'Debug.Print "SUCCESS: FieldRowNum function found the string """ & fieldName & """ in row " & inverseRowNum & ", column number " & colNum & "." 1200 | Exit Function 1201 | End If 1202 | 1203 | Next i 1204 | 1205 | 'Debug.Print "WARNING: FieldRowNum function did not find the string """ & fieldName & """ in column number " & colNum & "." 1206 | Exit Function 1207 | 1208 | If colNum = 0 Then 1209 | On Error Resume Next 1210 | colLet = "A" 1211 | rowNum = Application.WorksheetFunction.Match(fieldName, ws.Columns(colLet & ":" & colLet), 0) 1212 | fieldFound = True 1213 | FieldRowNum = rowNum 1214 | On Error GoTo 0 1215 | 'Debug.Print "SUCCESS: FieldRowNum function found the string """ & fieldName & """ in row " & rowNum & ", column number " & colNum & "." 1216 | Exit Function 1217 | End If 1218 | 1219 | ' Debug.Print "WARNING: FieldRowNum function did not find the string """ & fieldName & """ in column number " & colNum & "." 1220 | Exit Function 1221 | End If 1222 | 1223 | Else 1224 | 1225 | If (fromTop = True) Or (fromTop = False And fromBottom = False) Then 1226 | If (colNum <> 0) Then 1227 | If startRowNum = 0 Then 1228 | startRowNum = 1 1229 | End If 1230 | 1231 | For i = startRowNum To lastRow(ws) 1232 | 1233 | If (ws.Cells(i, colNum) = fieldName) Then 1234 | FieldRowNum = i 1235 | 'Debug.Print "SUCCESS: FieldRowNum function found the string """ & fieldName & """ in row " & i & ", column number " & colNum & "." 1236 | Exit Function 1237 | End If 1238 | 1239 | Next i 1240 | 1241 | 'Debug.Print "WARNING: FieldRowNum function did not find the string """ & fieldName & """ in column number " & colNum & "." 1242 | Exit Function 1243 | End If 1244 | 1245 | If colNum = 0 Then 1246 | On Error Resume Next 1247 | colLet = "A" 1248 | rowNum = Application.WorksheetFunction.Match(fieldName, ws.Columns(colLet & ":" & colLet), 0) 1249 | fieldFound = True 1250 | FieldRowNum = rowNum 1251 | On Error GoTo 0 1252 | 'Debug.Print "SUCCESS: FieldRowNum function found the string """ & fieldName & """ in row " & rowNum & ", column number " & colNum & "." 1253 | Exit Function 1254 | End If 1255 | 1256 | 'Debug.Print "WARNING: FieldRowNum function did not find the string """ & fieldName & """ in column number " & colNum & "." 1257 | Exit Function 1258 | End If 1259 | 1260 | If (fromBottom = True) Then 1261 | If (colNum <> 0) Then 1262 | If startRowNum = 0 Then 1263 | startRowNum = lastRow(ws) 1264 | End If 1265 | 1266 | origRowCount = lastRow(ws) 1267 | 1268 | For i = 1 To startRowNum 1269 | inverseRowNum = startRowNum - i + 1 1270 | 1271 | If (ws.Cells(inverseRowNum, colNum) = fieldName) Then 1272 | FieldRowNum = inverseRowNum 1273 | 'Debug.Print "SUCCESS: FieldRowNum function found the string """ & fieldName & """ in row " & inverseRowNum & ", column number " & colNum & "." 1274 | Exit Function 1275 | End If 1276 | 1277 | Next i 1278 | 1279 | 'Debug.Print "WARNING: FieldRowNum function did not find the string """ & fieldName & """ in column number " & colNum & "." 1280 | Exit Function 1281 | End If 1282 | 1283 | If colNum = 0 Then 1284 | On Error Resume Next 1285 | colLet = "A" 1286 | rowNum = Application.WorksheetFunction.Match(fieldName, ws.Columns(colLet & ":" & colLet), 0) 1287 | fieldFound = True 1288 | FieldRowNum = rowNum 1289 | On Error GoTo 0 1290 | 'Debug.Print "SUCCESS: FieldRowNum function found the string """ & fieldName & """ in row " & rowNum & ", column number " & colNum & "." 1291 | Exit Function 1292 | End If 1293 | 1294 | ' Debug.Print "WARNING: FieldRowNum function did not find the string """ & fieldName & """ in column number " & colNum & "." 1295 | Exit Function 1296 | End If 1297 | End If 1298 | 1299 | End Function 1300 | 'Sub testt() 1301 | 'Dim wsDest As Worksheet, wsSource As Worksheet 1302 | ' 1303 | 'Set wsDest = Workbooks("OneWestNonRecurringAlerts.csv").Worksheets("OneWestNonRecurringAlerts") 1304 | 'Set wsSource = Workbooks("ClientReferenceList.xlsx").Worksheets("ClientUmbrella") 1305 | ' 1306 | 'vbaLookup2 wsDest, "ClientNameCondensed", "ClientName", wsSource, "ClientName", "UmbrellaName" 1307 | ' 1308 | 'End Sub 1309 | Public Sub vbaLookup2(ByVal wsDest As Worksheet, ByVal destField As String, ByVal destKeyField As String, _ 1310 | ByVal wsSource As Worksheet, ByVal sourceKeyField As String, Optional ByVal sourceValueField As String, _ 1311 | Optional insertNewColumn As Boolean, Optional keyFoundValue As String, Optional keyNotFoundValue As String, _ 1312 | Optional ByVal destStartRow As Long, Optional ByVal sourceStartRow As Long, Optional ByVal createNewLastColumn As Boolean) 1313 | '// Authored by Nathan N on 7/2/2012 1314 | '// Updated 1/16/2015 1315 | '// Improved version of the vbaLookup. Uses the a dictionary object (built into other languages) that fills with key-value pairs. 1316 | ' --Measured exponential speed savings as data set gets larger (very large data sets took longer than 10 minutes with the old vbaLookup, but with vbaLookup2 it took 40 seconds) 1317 | ' --Option for new column to be inserted into the destination workbook which takes on the destField as the column title 1318 | ' --Can return optional custom value (instead of matched value)blank or optional value if Key is not found in dictionary 1319 | ' If keyFoundValue is used, then sourceValueField is not required, and in fact will be ignored. 1320 | 1321 | '// Future Improvements: Create multiple dictionaries, or 'buckets,' with the quantity of buckets increasing with proportion to the most 1322 | '// common first few characters 1323 | 1324 | Dim destKeyCol As Integer, destFieldCol As Integer, sourceKeyCol As Integer, sourceValueCol As Integer 1325 | Dim rngDest As Range 1326 | Dim i As Long 1327 | 1328 | '// Variables for the Dictionary Object 1329 | Dim d As Object 1330 | Dim key As String, value As String, keyToMatch As String 1331 | 1332 | '// Set option below (vbTextCompare ignores upper/lowercase, while vbBinaryCompare is faster but requires exact matches 1333 | Set d = CreateObject("Scripting.Dictionary") 1334 | d.CompareMode = vbTextCompare 1335 | 'd.CompareMode = vbBinaryCompare 1336 | 'd.CompareMode = vbDatabaseCompare 1337 | 'd.CompareMode = vbUseCompareOption (THIS IS WHATEVER THE IDE HAS BEEN DEFAULTED TO. DO A GOOGLE SEARCH TO FIND OUT HOW TO SET THIS) 1338 | 1339 | destKeyCol = FieldColNum(wsDest, destKeyField) 1340 | 1341 | '// Insert Optional New Column 1342 | If insertNewColumn = True Then 1343 | If destStartRow > 0 Then 1344 | If FieldExists(wsDest, destField, destStartRow, True) Then Debug.Print "vbaLookup2 Warning: Destination Field Name Already Exists" 1345 | Else 1346 | If FieldExists(wsDest, destField, , True) Then Debug.Print "vbaLookup2 Warning: Destination Field Name Already Exists" 1347 | End If 1348 | destFieldCol = destKeyCol + 1 1349 | wsDest.Columns(destFieldCol).Insert Shift:=xlRight 1350 | wsDest.Cells(1, destFieldCol) = destField 1351 | ElseIf createNewLastColumn = True Then 1352 | destFieldCol = lastColNum(wsDest) + 1 1353 | wsDest.Cells(1, destFieldCol) = destField 1354 | Else 1355 | If FieldExists(wsDest, destField) Then 1356 | destFieldCol = FieldColNum(wsDest, destField) 1357 | Else 1358 | Debug.Print "vbaLookUp2 Error: destField = """ & destField & """ does not exist" 1359 | Exit Sub 1360 | End If 1361 | End If 1362 | sourceKeyCol = FieldColNum(wsSource, sourceKeyField) 1363 | sourceValueCol = FieldColNum(wsSource, sourceValueField) 1364 | 1365 | '// Create Dictionary with key-value pairs from the source worksheet 1366 | If keyFoundValue = "" Then 1367 | For i = 2 To lastRow(wsSource) 1368 | key = wsSource.Cells(i, sourceKeyCol) 1369 | value = wsSource.Cells(i, sourceValueCol) 1370 | If Not d.Exists(key) Then d.Add key, value 1371 | Next i 1372 | Else 1373 | For i = 2 To lastRow(wsSource) 1374 | key = wsSource.Cells(i, sourceKeyCol) 1375 | value = keyFoundValue 1376 | If Not d.Exists(key) Then d.Add key, value 1377 | Next i 1378 | End If 1379 | '// Match destKey (keyToMatch) with corresponding values 1380 | If keyNotFoundValue = "" Then 1381 | '// Algorithm for the default blank value for keys that were not found in the dictionary 1382 | For i = 2 To lastRow(wsDest, , destKeyCol) 1383 | Set rngDest = wsDest.Cells(i, destFieldCol) 1384 | keyToMatch = wsDest.Cells(i, destKeyCol) 1385 | rngDest.value = d(keyToMatch) 1386 | Next i 1387 | ElseIf keyFoundValue = "" And keyNotFoundValue <> "" Then 1388 | '// Algorithm for user specified value for keys that were not found in the dictionary 1389 | For i = 2 To lastRow(wsDest, , destKeyCol) 1390 | Set rngDest = wsDest.Cells(i, destFieldCol) 1391 | keyToMatch = wsDest.Cells(i, destKeyCol) 1392 | If d.Exists(keyToMatch) Then 1393 | rngDest.value = d(keyToMatch) 1394 | Else 1395 | rngDest.value = keyNotFoundValue 1396 | End If 1397 | Next i 1398 | ElseIf keyFoundValue <> "" And keyNotFoundValue <> "" Then 1399 | For i = 2 To lastRow(wsDest, , destKeyCol) 1400 | Set rngDest = wsDest.Cells(i, destFieldCol) 1401 | keyToMatch = wsDest.Cells(i, destKeyCol) 1402 | If d.Exists(keyToMatch) Then 1403 | rngDest.value = keyFoundValue 1404 | Else 1405 | rngDest.value = keyNotFoundValue 1406 | End If 1407 | Next i 1408 | End If 1409 | 1410 | Set d = Nothing 1411 | 1412 | End Sub 1413 | 1414 | Public Sub vbaLookup(ByVal currentSheet As Worksheet, ByVal destField As String, ByVal matchField As String, ByVal sourceSheet As Worksheet, ByVal sourceMatchField As String, ByVal sourceMatchDataField As String, Optional ByVal destMatchFieldRowNum As Long, Optional ByVal sourceFieldRowNum As Long) 1415 | '**** 1/31/2012 **** 1416 | 'Updated 3/1/2012 at 5:24PM - Added Error notifications for unknown clients to be added to the client list 1417 | 'Updated 3/2/2012 at 1:16PM - Added destFieldRowNum Option and sourceFieldRowNum Option 1418 | ' - Corrected error nofication to send only on a client error trigger 1419 | Dim destFieldColNum As Integer, matchFieldColNum As Integer, sourceMatchFieldColNum As Integer, sourceMatchDataFieldColNum As Integer 1420 | Dim i As Long 1421 | 1422 | Application.ScreenUpdating = False 1423 | 1424 | If (destMatchFieldRowNum = 0) Then 1425 | destMatchFieldRowNum = 1 1426 | End If 1427 | If (sourceFieldRowNum = 0) Then 1428 | sourceFieldRowNum = 1 1429 | End If 1430 | 1431 | destFieldColNum = Application.WorksheetFunction.Match(destField, currentSheet.Rows(destMatchFieldRowNum), 0) 1432 | matchFieldColNum = Application.WorksheetFunction.Match(matchField, currentSheet.Rows(destMatchFieldRowNum), 0) 1433 | sourceMatchFieldColNum = Application.WorksheetFunction.Match(sourceMatchField, sourceSheet.Rows(sourceFieldRowNum), 0) 1434 | sourceMatchDataFieldColNum = Application.WorksheetFunction.Match(sourceMatchDataField, sourceSheet.Rows(sourceFieldRowNum), 0) 1435 | 1436 | For i = destMatchFieldRowNum + 1 To lastRow(currentSheet, , , destMatchFieldRowNum) 1437 | 'Debug.Print lastRow(currentSheet, , , destMatchFieldRowNum) 1438 | On Error GoTo ErrHandlerClient 1439 | sourceMatchRow = Application.WorksheetFunction.Match(currentSheet.Cells(i, matchFieldColNum).value, sourceSheet.Columns(sourceMatchFieldColNum), 0) 1440 | currentSheet.Cells(i, destFieldColNum).value = sourceSheet.Cells(sourceMatchRow, sourceMatchDataFieldColNum).value 1441 | 1442 | NextItem: 1443 | Next i 1444 | 1445 | On Error GoTo 0 1446 | 1447 | Application.ScreenUpdating = False 1448 | 1449 | Exit Sub 1450 | 1451 | ErrHandlerClient: 1452 | Err.Clear 1453 | If (InStr(1, LCase(currentSheet.Cells(1, matchFieldColNum)), "client") > 0) Then 1454 | EmailWhoever "user@domain.com", "", "Unknown client """ & currentSheet.Cells(i, matchFieldColNum) & """ listed in workbook """ & currentSheet.Parent.Name & """ in worksheet " & currentSheet.Name 1455 | currentSheet.Cells(i, matchFieldColNum + 1) = "[UNKNOWN CLIENT]" 1456 | Else 1457 | 'EmailWhoever "user@domain.com", "", "There was no match found for """ & currentSheet.Cells(i, matchFieldColNum) & """ listed in workbook """ & currentSheet.Parent.Name & """ in worksheet " & currentSheet.Name 1458 | 'currentSheet.Cells(i, matchFieldColNum + 1) = "[UNKNOWN CLIENT]" 1459 | End If 1460 | Resume NextItem 1461 | 1462 | End Sub 1463 | Public Sub VbaZipLookup(ByVal currentSheet As Worksheet, ByVal destField As String, ByVal matchField As String, ByVal sourceSheet As Worksheet, ByVal sourceMatchField As String, ByVal sourceMatchDataField As String, Optional ByVal listStates As Boolean, Optional ByVal matchFieldRowNum As Long, Optional ByVal sourceFieldRowNum As Long) 1464 | '*** Copied from VbaLookup function - specifically created for the CountyMatching programs - Matches both county and state info to a zip code list*** 1465 | '*** Edited by Nathan N on 6/15/2012 *** 1466 | '// Updated 6/26/2012: Only added '0 NOT FOUND' to state column if it was generated by the caller (to the right of the zip code column) 1467 | 1468 | Dim destFieldColNum As Integer, matchFieldColNum As Integer, sourceMatchFieldColNum As Integer, sourceMatchDataFieldColNum As Integer 1469 | Dim i As Long 1470 | 1471 | If (matchFieldRowNum = 0) Then 1472 | matchFieldRowNum = 1 1473 | End If 1474 | If (sourceFieldRowNum = 0) Then 1475 | sourceFieldRowNum = 1 1476 | End If 1477 | 1478 | destFieldColNum = Application.WorksheetFunction.Match(destField, currentSheet.Rows(matchFieldRowNum), 0) 1479 | If listStates = True Then stateFieldColNum = Application.WorksheetFunction.Match("State", currentSheet.Rows(matchFieldRowNum), 0) 1480 | matchFieldColNum = Application.WorksheetFunction.Match(matchField, currentSheet.Rows(matchFieldRowNum), 0) 1481 | sourceMatchFieldColNum = Application.WorksheetFunction.Match(sourceMatchField, sourceSheet.Rows(sourceFieldRowNum), 0) 1482 | sourceMatchDataFieldColNum = Application.WorksheetFunction.Match(sourceMatchDataField, sourceSheet.Rows(sourceFieldRowNum), 0) 1483 | If listStates = True Then sourceMatchStateDataFieldColNum = Application.WorksheetFunction.Match("State", sourceSheet.Rows(sourceFieldRowNum), 0) 1484 | 1485 | If listStates = True Then stateMatchFieldColNum = Application.WorksheetFunction.Match("State", currentSheet.Rows(matchFieldRowNum), 0) 1486 | 1487 | For i = matchFieldRowNum + 1 To lastRow(currentSheet, , , matchFieldRowNum) 1488 | On Error GoTo ErrHandlerClient 1489 | sourceMatchRow = Application.WorksheetFunction.Match(currentSheet.Cells(i, matchFieldColNum).value, sourceSheet.Columns(sourceMatchFieldColNum), 0) 1490 | currentSheet.Cells(i, destFieldColNum).value = sourceSheet.Cells(sourceMatchRow, sourceMatchDataFieldColNum).value 1491 | If listStates = True Then 1492 | currentSheet.Cells(i, stateFieldColNum).value = sourceSheet.Cells(sourceMatchRow, sourceMatchStateDataFieldColNum).value 1493 | End If 1494 | NextItem: 1495 | Next i 1496 | 1497 | On Error GoTo 0 1498 | 1499 | Exit Sub 1500 | 1501 | ErrHandlerClient: 1502 | Err.Clear 1503 | If (InStr(1, LCase(currentSheet.Cells(1, matchFieldColNum)), "client") > 0) Then 1504 | EmailWhoever "user@domain.com", "", "Unknown client """ & currentSheet.Cells(i, matchFieldColNum) & """ listed in workbook """ & currentSheet.Parent.Name & """ in worksheet " & currentSheet.Name 1505 | currentSheet.Cells(i, matchFieldColNum + 1) = "[UNKNOWN CLIENT]" 1506 | Else 1507 | currentSheet.Cells(i, matchFieldColNum + 1) = "0 NOT FOUND" 1508 | If listStates = True And currentSheet.Cells(1, matchFieldColNum + 2) = "State" Then currentSheet.Cells(i, matchFieldColNum + 2) = "0 NOT FOUND" '// this may not work properly if the data state column happened to be in the same place 1509 | 'EmailWhoever "user@domain.com", "", "There was no match found for """ & currentSheet.Cells(i, matchFieldColNum) & """ listed in workbook """ & currentSheet.Parent.Name & """ in worksheet " & currentSheet.Name 1510 | 'currentSheet.Cells(i, matchFieldColNum + 1) = "[UNKNOWN CLIENT]" 1511 | End If 1512 | Resume NextItem 1513 | 1514 | End Sub 1515 | Public Function lastEntryInRow(ByVal ws As Worksheet, ByVal rowNum As Long) As Long 1516 | 'Created by Nathan N on 4/19/2012 1517 | Dim i As Long 1518 | 1519 | For i = 1 To 1000 1520 | 1521 | If (Len(ws.Cells(rowNum, i)) <= 0) Then 1522 | lastEntryInRow = i - 1 1523 | Exit Function 1524 | End If 1525 | 1526 | Next i 1527 | 1528 | End Function 1529 | Public Sub AddColorToCol(ByVal currentSheet As Worksheet, startRow As Long, Optional ByVal colNum As Integer, Optional ByVal colLet As String) 1530 | '********************************************************* 1531 | '*** Authored by Nathan N, on 1/13/2012 1532 | '*** 1533 | '*** Designed to be used with a pivot table, this adds color to a column 1534 | '*** within a pivot table, excluding the footer 1535 | '*** PreCondition: A starting row number (startRow) must be declared (in case 1536 | '*** there are multiple pivot tables in the same column space). 1537 | '********************************************************* 1538 | Dim lastRow As Long 1539 | 1540 | If colNum > 0 Then 1541 | colLet = ColNumToLet(currentSheet, colNum) 1542 | Else 1543 | colLet = ColNumToLet(currentSheet, lastColNum(currentSheet)) 1544 | End If 1545 | 1546 | lastRow = currentSheet.Range(colLet & Rows.Count).End(xlUp).Row - 1 1547 | 1548 | currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions.Delete 1549 | 1550 | currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions.AddColorScale ColorScaleType:=3 1551 | currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions(currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions.Count).SetFirstPriority 1552 | currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue 1553 | With currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions(1).ColorScaleCriteria(1).FormatColor 1554 | .Color = 13011546 1555 | .TintAndShade = 0 1556 | End With 1557 | currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile 1558 | currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions(1).ColorScaleCriteria(2).value = 50 1559 | With currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions(1).ColorScaleCriteria(2).FormatColor 1560 | .Color = 8711167 1561 | .TintAndShade = 0 1562 | End With 1563 | currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue 1564 | With currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions(1).ColorScaleCriteria(3).FormatColor 1565 | .Color = 7039480 1566 | .TintAndShade = 0 1567 | End With 1568 | 1569 | End Sub 1570 | Public Sub AddColorToColLimit(ByVal currentSheet As Worksheet, startRow As Long, Optional ByVal colNum As Integer, Optional ByVal colLet As String) 1571 | '********************************************************* 1572 | '*** Authored by Nathan N, on 2/6/2012 1573 | '*** 1574 | '*** Designed to be used with a pivot table, this adds color to a column 1575 | '*** within a pivot table, excluding the footer, according to specified values 1576 | '*** PreCondition: A starting row number (startRow) must be declared (in case 1577 | '*** there are multiple pivot tables in the same column space). 1578 | '********************************************************* 1579 | 1580 | Dim lastRow As Long 1581 | Dim cs As ColorScale 1582 | 1583 | If colNum > 0 Then colLet = ColNumToLet(currentSheet, colNum) 1584 | 1585 | lastRow = currentSheet.Range(colLet & Rows.Count).End(xlUp).Row - 1 1586 | 1587 | currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions.Delete 1588 | 1589 | Set cs = currentSheet.Range(colLet & startRow & ":" & colLet & lastRow).FormatConditions.AddColorScale(3) 1590 | 1591 | cs.ColorScaleCriteria(1).Type = xlConditionValueNumber 1592 | cs.ColorScaleCriteria(1).value = 0.95 1593 | cs.ColorScaleCriteria(1).FormatColor.Color = 7039480 1594 | 1595 | cs.ColorScaleCriteria(2).Type = xlConditionValueNumber 1596 | cs.ColorScaleCriteria(2).value = 0.8 1597 | cs.ColorScaleCriteria(2).FormatColor.Color = 8711167 1598 | 1599 | cs.ColorScaleCriteria(3).Type = xlConditionValueNumber 1600 | cs.ColorScaleCriteria(3).value = 0.7 1601 | cs.ColorScaleCriteria(3).FormatColor.Color = 13011546 1602 | 1603 | End Sub 1604 | Public Function createPivot(ByVal sourceSheet As Worksheet, ByVal destSheet As Worksheet, ByVal destCell As String, ByVal pivotName As String, _ 1605 | ByVal countItem As String, Optional ByVal titleName As String, Optional ByVal rowItem1 As String, Optional ByVal colItem1 As String, Optional ByVal rowItem2 As String, _ 1606 | Optional ByVal rowItem3 As String, Optional ByVal colItem2 As String, Optional ByVal colItem3 As String, Optional lastCol As Integer) As PivotCaches 1607 | '********************************************************* 1608 | '*** Authored by Nathan N, on 1/13/2012 1609 | '*** 1610 | '*** Updated 3/6/2012 - Added optional lastCol parameter 1611 | '*** Updated 3/8/2012 - Improved lastCol auto detection (error in excel gets the last col incorrect sometimes) 1612 | '*** 1613 | '*** This creates an aesthetically pleasing pivot table with more ease than 1614 | '*** the built-in excel functions. Supports up to three row categories and 1615 | '*** three column categories. Note that this pivot table only supports Count; 1616 | '*** it does not support Sum. 1617 | '*** 1618 | '*** PreCondition: Field names on the source worksheet must be on the first row. 1619 | '*** Additionally, data must be entered in one or more rows underneath 1620 | '*** the field names 1621 | '*** 1622 | '*** User must declare the following: 1623 | '*** 1. Source workbook name 1624 | '*** 2. Source worksheet name 1625 | '*** 3. A destination worksheet 1626 | '*** 4. A destination cell, ex: "A3" 1627 | '*** 5. A Pivot Name 1628 | '*** 6. The Field for which the pivot table should Count 1629 | '*** 7. Option variables are used to title the pivot table, which 1630 | '*** is different from the pivotName (which is the name that 1631 | '*** is used by excel to manipulate data), as well as add various 1632 | '*** fields to the pivot table 1633 | '*** 1634 | '*** PostCondition: A new pivot table object is created and named pivotName 1635 | '********************************************************* 1636 | 1637 | 'Dim lastRowP As Long 1638 | Dim sourceRange As String 1639 | Dim i As Long 1640 | 1641 | 'lastRowP = lastRow(sourceSheet) 1642 | 1643 | If (lastCol = 0) Then 1644 | For i = 1 To sourceSheet.UsedRange.Columns.Count + 1 1645 | If (sourceSheet.Cells(1, i) = "") Then 1646 | lastCol = i - 1 1647 | Exit For 1648 | End If 1649 | Next i 1650 | End If 1651 | 1652 | sourceRange = sourceSheet.Name & "!R1C1:R" & lastRow(sourceSheet) & "C" & lastCol 1653 | 'Debug.Print countItem 1654 | 1655 | sourceSheet.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=sourceRange, Version:=xlPivotTableVersion12).CreatePivotTable TableDestination:=destSheet.Range(destCell), TableName:=pivotName, DefaultVersion:=xlPivotTableVersion12 1656 | 1657 | destSheet.PivotTables(pivotName).AddDataField destSheet.PivotTables(pivotName).PivotFields(countItem), "Count of " & countItem, xlCount 1658 | 1659 | '**** If the user has entered the optional parameters below, then the Function adds these to the pivot table dimensions **** 1660 | If colItem1 <> "" Then 1661 | With destSheet.PivotTables(pivotName).PivotFields(colItem1) 1662 | .Orientation = xlColumnField 1663 | .Position = 1 1664 | End With 1665 | End If 1666 | If rowItem1 <> "" Then 1667 | With destSheet.PivotTables(pivotName).PivotFields(rowItem1) 1668 | .Orientation = xlRowField 1669 | .Position = 1 1670 | End With 1671 | End If 1672 | If rowItem2 <> "" Then 1673 | With destSheet.PivotTables(pivotName).PivotFields(rowItem2) 1674 | .Orientation = xlRowField 1675 | .Position = 2 1676 | End With 1677 | End If 1678 | If rowItem3 <> "" Then 1679 | With destSheet.PivotTables(pivotName).PivotFields(rowItem3) 1680 | .Orientation = xlRowField 1681 | .Position = 3 1682 | End With 1683 | End If 1684 | If colItem2 <> "" Then 1685 | With destSheet.PivotTables(pivotName).PivotFields(colItem2) 1686 | .Orientation = xlColumnField 1687 | .Position = 2 1688 | End With 1689 | End If 1690 | If colItem3 <> "" Then 1691 | With destSheet.PivotTables(pivotName).PivotFields(colItem3) 1692 | .Orientation = xlColumnField 1693 | .Position = 3 1694 | End With 1695 | End If 1696 | If titleName <> "" Then 1697 | destSheet.PivotTables(pivotName).CompactLayoutRowHeader = titleName 1698 | End If 1699 | End Function 1700 | Public Sub CreatePivotFromExisting(ByVal sourceSheet As Worksheet, ByVal sourcePivName As String, ByVal destSheet As Worksheet, ByVal destCell As String, _ 1701 | ByVal destPivotName As String, ByVal countItem As String, Optional ByVal titleName As String, Optional ByVal rowItem1 As String, Optional ByVal colItem1 As String, Optional ByVal rowItem2 As String, _ 1702 | Optional ByVal rowItem3 As String, Optional ByVal colItem2 As String, Optional ByVal colItem3 As String) 1703 | '********************************************************* 1704 | '*** Authored by Nathan N, on 1/13/2012 1705 | '*** This creates an aesthetically pleasing pivot table with more ease than 1706 | '*** the built-in excel functions. Supports up to three row categories and 1707 | '*** three column categories. Note that this pivot table only supports Count; 1708 | '*** it does not support Sum. 1709 | '********************************************************* 1710 | 1711 | Dim pc As PivotCache, pt As PivotTable 1712 | 1713 | 'Set pc = wb.PivotCache(sourcePivotName) 1714 | 'Set pt = wb.CreatePivotTable destSheet.Range(destCell), destPivotName, True 1715 | Set pc = sourceSheet.PivotTables(1).PivotCache 1716 | Set pt = pc.CreatePivotTable(destSheet.Range(destCell), destPivotName, True) 1717 | 'sourcewb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=sourceRange, Version:=xlPivotTableVersion12).CreatePivotTable TableDestination:=destSheet.Range(destCell), TableName:=pivotName, DefaultVersion:=xlPivotTableVersion12 1718 | pt.AddDataField pt.PivotFields(countItem), "Count of " & countItem, xlCount 1719 | 1720 | 'pt.AddFields (pt.PivotFields("pivotFieldName").Name) 1721 | '**** If the user has entered the optional parameters below, then the Function adds these to the pivot table dimensions **** 1722 | If colItem1 <> "" Then 1723 | With pt.PivotFields(colItem1) 1724 | .Orientation = xlColumnField 1725 | .Position = 1 1726 | End With 1727 | End If 1728 | If rowItem1 <> "" Then 1729 | With pt.PivotFields(rowItem1) 1730 | .Orientation = xlRowField 1731 | .Position = 1 1732 | End With 1733 | End If 1734 | If rowItem2 <> "" Then 1735 | With destSheet.PivotTables(destPivotName).PivotFields(rowItem2) 1736 | .Orientation = xlRowField 1737 | .Position = 2 1738 | End With 1739 | End If 1740 | If rowItem3 <> "" Then 1741 | With destSheet.PivotTables(destPivotName).PivotFields(rowItem3) 1742 | .Orientation = xlRowField 1743 | .Position = 3 1744 | End With 1745 | End If 1746 | If colItem2 <> "" Then 1747 | With destSheet.PivotTables(destPivotName).PivotFields(colItem2) 1748 | .Orientation = xlColumnField 1749 | .Position = 2 1750 | End With 1751 | End If 1752 | If colItem3 <> "" Then 1753 | With destSheet.PivotTables(destPivotName).PivotFields(colItem3) 1754 | .Orientation = xlColumnField 1755 | .Position = 3 1756 | End With 1757 | End If 1758 | 1759 | If titleName <> "" Then destSheet.PivotTables(destPivotName).CompactLayoutRowHeader = titleName 1760 | 1761 | End Sub 1762 | Public Sub MoveSheets(sheetToMove As Worksheet, sheetAnchor As Worksheet, beforeOrAfter As String) 1763 | '********************************************************* 1764 | '*** Authored by Nathan N, on 1/13/2012 1765 | '*** 1766 | '*** Moves worksheets around a workbook for aesthetic reorganization 1767 | '*** the sheetAnchor variable is the worksheet for which the other worksheet 1768 | '*** will move around (before or after) 1769 | '*** 1770 | '*** PreCondition: sheetToMove & sheetAnchor are declared. 1771 | '*** beforeOrAfter uses the values "before" or "after" 1772 | '*** PostCondition: Does not return a value. beforeOrAfter is set to "". 1773 | '********************************************************* 1774 | 1775 | If beforeOrAfter = "before" Then sheetToMove.Move before:=sheetAnchor 1776 | 1777 | If beforeOrAfter = "after" Then sheetToMove.Move after:=sheetAnchor 1778 | 1779 | beforeOrAfter = "" 1780 | 1781 | End Sub 1782 | Public Sub FormatRowToDefault(ByVal ws As Worksheet, ByVal rowNum As Integer, Optional ByVal startCol As Integer, Optional ByVal endCol As Integer, Optional startLet As String, Optional endLet As String) 1783 | '********************************************************* 1784 | '*** Authored by Nathan N, on 1/13/2012 1785 | '*** 1786 | '*** Updated on 6/8/2012 by Nathan N: Added default startCol/endCol to equal 1 if no optional argument was provided 1787 | '*** Formats extra textual row additions to a pivot table to look as if it is a part of the 1788 | '*** default pivot table, as opposed to added text 1789 | '*** 1790 | '*** PreCondition: ws must be declared. startLet and endLet specify 1791 | '*** the range for which the formatting should apply. 1792 | '*** lastRowFormatting is either True or False, and indicates whether the 1793 | '*** formatting should apply to the last row or not. If set to True, then 1794 | '*** the optional topRowNum is not needed. 1795 | '*** 1796 | '*** PostCondition: Does not return a value. 1797 | '*** 1798 | '********************************************************* 1799 | Dim rng As Range 1800 | 1801 | If startCol = 0 Then startCol = 1 1802 | If endCol = 0 Then endCol = 1 1803 | 1804 | If startCol <> 0 And endCol <> 0 And (startLet = "" Or endLet = "") Then 1805 | Set rng = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) 1806 | With rng.Interior 1807 | .Pattern = xlSolid 1808 | .PatternColorIndex = xlAutomatic 1809 | .ThemeColor = xlThemeColorAccent1 1810 | .TintAndShade = 0.799981688894314 1811 | .PatternTintAndShade = 0 1812 | End With 1813 | rng.Font.Bold = True 1814 | Exit Sub 1815 | End If 1816 | 1817 | If startLet <> "" And endLet <> "" Then 1818 | rng = ws.Range(startLet & topRowNum & ":" & endLet & topRowNum) 1819 | With rng.Interior 1820 | .Pattern = xlSolid 1821 | .PatternColorIndex = xlAutomatic 1822 | .ThemeColor = xlThemeColorAccent1 1823 | .TintAndShade = 0.799981688894314 1824 | .PatternTintAndShade = 0 1825 | End With 1826 | ws.Range(rng).Font.Bold = True 1827 | Exit Sub 1828 | End If 1829 | 1830 | End Sub 1831 | Public Sub FormatColToDefault(ByVal ws As Worksheet, ByVal startCol As Integer, Optional ByVal endCol As Integer) 1832 | '********************************************************* 1833 | '*** Authored by Nathan N, on 1/27/2012 1834 | '*** 1835 | '*** Formats extra col textual additions to a pivot table to look as if it is a part of the 1836 | '*** default pivot table, as opposed to added text 1837 | '*** 1838 | '*** PreCondition: ws must be declared. 1839 | '*** 1840 | '*** PostCondition: Does not return a value. 1841 | '*** 1842 | '********************************************************* 1843 | Dim i As Integer 1844 | 1845 | If endCol = 0 Then 1846 | With ws.Columns(startCol) 1847 | .ColumnWidth = 14.57 1848 | .HorizontalAlignment = xlCenter 1849 | .WrapText = True 1850 | End With 1851 | End If 1852 | 1853 | 'If endCol <> 0 Then 1854 | ' ws.Columns(CStr(startCol) & ":" & CStr(endCol)).ColumnWidth = 14.57 1855 | ' ws.Columns(CStr(startCol) & ":" & CStr(endCol)).HorizontalAlignment = xlCenter 1856 | ' ws.Columns(CStr(startCol) & ":" & CStr(endCol)).VerticalAlignment = xlCenter 1857 | ' ws.Columns(CStr(startCol) & ":" & CStr(endCol)).WrapText = True 1858 | 'End If 1859 | 1860 | If endCol <> 0 Then 1861 | For i = startCol To endCol 1862 | With ws.Columns(i) 1863 | .ColumnWidth = 14.57 1864 | .HorizontalAlignment = xlCenter 1865 | .VerticalAlignment = xlCenter 1866 | .WrapText = True 1867 | End With 1868 | Next i 1869 | End If 1870 | 1871 | End Sub 1872 | Public Function FieldExists(ByVal currentSheet As Worksheet, ByVal fieldName As String, Optional ByVal rowNum As Integer, Optional ByVal exactMatch As Boolean) As Boolean 1873 | '*** Authored by Nathan N on 1/18/2012 *** 1874 | '*** Updated on 2/3/2012 at 11:40AM - Added default rowNum = 1 1875 | '*** Updated on 5/2/2012 at 10:22 AM - Included exactMatch functionality 1876 | 1877 | Dim colNum As Integer, fieldList As String, fieldNameLoc As Integer 1878 | 1879 | '** Set Default Row Number (1) if rowNum = 0 ** 1880 | If rowNum = 0 Then rowNum = 1 1881 | 1882 | fieldList = "" 1883 | fieldNameLoc = 0 1884 | 1885 | If (exactMatch = False) Then 1886 | 1887 | For i = 1 To lastColNum(currentSheet) 1888 | fieldList = currentSheet.Cells(rowNum, i).value & "," & fieldList 1889 | Next i 1890 | 1891 | fieldNameLoc = InStr(1, fieldList, fieldName) 1892 | 1893 | If fieldNameLoc > 0 Then 1894 | FieldExists = True 1895 | Else 1896 | FieldExists = False 1897 | End If 1898 | 1899 | Exit Function 1900 | 1901 | Else 1902 | 1903 | On Error Resume Next 1904 | fieldNameLoc = Application.WorksheetFunction.Match(fieldName, currentSheet.Rows(rowNum), 0) 1905 | 1906 | If fieldNameLoc > 0 Then 1907 | FieldExists = True 1908 | Else 1909 | FieldExists = False 1910 | End If 1911 | 1912 | On Error GoTo 0 1913 | Exit Function 1914 | End If 1915 | 1916 | End Function 1917 | Public Function SheetExists(ByVal wb As Workbook, ByVal sheetName As String) As Boolean 1918 | '*** Authored by Nathan N on 2/3/2012*** 1919 | On Error Resume Next 1920 | 1921 | For Each ws In wb.Worksheets 1922 | 1923 | If ws.Name = sheetName Then 1924 | 'Debug.Print ws.Name 1925 | SheetExists = True 1926 | On Error GoTo 0 1927 | Exit Function 1928 | End If 1929 | 1930 | Next ws 1931 | 1932 | On Error GoTo 0 1933 | 1934 | End Function 1935 | 1936 | Public Sub EmailWhoever(recipients As String, Optional BCC_Recipients As String, Optional emailSubject As String, Optional signatureName As String, Optional attachmentFile As String, Optional txtBody As String) 1937 | 1938 | '********************************************************* 1939 | '*** Authored by Nathan N, on 5/1/2009 1940 | '*** Note that "signLoc" may be different on your system, and should be adjusted accordingly. 1941 | '*** Updated on 5/22/2012 - added option for text in body (txtBody). Also removed conditionals that were not needed. 1942 | '*** Updated on 2/1/2012 - replaced loginName strings with loginName() function 1943 | '*** 1944 | '*** Emails any number of recipients with one optional attachment. If more than 1945 | '*** one, a semicolon must be used, ex: "1@field.com; 2@woohoo.com". 1946 | '*** BCC recipients can also be specified. Does not support a CC list. 1947 | '*** 1948 | '*** PreCondition: At least one recipient must be specified. Everything else is 1949 | '*** optional. 1950 | '*** 1951 | '*** PostCondition: Does not return a value. 1952 | '*** 1953 | '********************************************************* 1954 | 1955 | Dim olApp As Outlook.Application 1956 | Dim olMail As MailItem 1957 | Dim signLoc As String 1958 | Dim signature As String 1959 | 1960 | If Len(signatureName) > 1 Then 1961 | 1962 | signLoc = "C:\Documents and Settings\" & loginName() & "\Application Data\Microsoft\Signatures\" & signatureName & ".htm" 1963 | 1964 | If Dir(signLoc) <> "" Then 1965 | signature = GetBoiler(signLoc) 1966 | Else 1967 | signature = "" 1968 | End If 1969 | 1970 | Else 1971 | signature = "" 1972 | End If 1973 | 1974 | '--begin email process-- 1975 | Set olApp = New Outlook.Application 1976 | Set olMail = olApp.CreateItem(olMailItem) 1977 | 1978 | With olMail 1979 | .To = recipients 1980 | .BCC = BCC_Recipients 1981 | .Subject = emailSubject 1982 | .HTMLBody = txtBody & vbCrLf & signature 1983 | If attachmentFile <> "" Then 1984 | .Attachments.Add attachmentFile 1985 | End If 1986 | ' .Display 1987 | .Send 1988 | End With 1989 | 1990 | Set olMail = Nothing 1991 | Set olApp = Nothing 1992 | 1993 | End Sub 1994 | Public Function findAndReplace(textToFind, containedInFile, replaceWith) As String 1995 | Dim transferText As Long 1996 | 1997 | transferText = FreeFile 1998 | 1999 | Open containedInFile For Input As #transferText 2000 | textContent = Input$(LOF(transferText), transferText) 2001 | Close #transferText 2002 | newText = Replace(textContent, textToFind, replaceWith) 2003 | 2004 | Open containedInFile For Output As transferText 2005 | Print #transferText, newText 2006 | Close #transferText 2007 | 2008 | findAndReplace = newText 2009 | 2010 | End Function 2011 | Public Sub replaceFileContents(containedInFile, replaceWith) 2012 | Dim transferText As Long 2013 | Dim transferText2 As Long 2014 | transferText = FreeFile 2015 | transferText2 = FreeFile 2016 | 2017 | Open containedInFile For Input As #transferText 2018 | textContent = Input$(LOF(transferText), transferText) 2019 | Close #transferText 2020 | 2021 | 'newText = Replace(textContent, textToFind, replaceWith) 2022 | 2023 | Open replaceWith For Input As #transferText2 2024 | textContent2 = Input$(LOF(transferText2), transferText2) 2025 | Close #transferText2 2026 | 2027 | Open containedInFile For Output As transferText 2028 | Print #transferText, textContent2 2029 | Close #transferText 2030 | 2031 | End Sub 2032 | Public Function FileExists(ByVal fileLocation As String) As Boolean 2033 | '// Changed function name to FileExists from FileThere because it made more sense 2034 | '// Authored by Nathan N on 6/5/2012 2035 | '// Checks to see if a certain file 2036 | 2037 | FileExists = (Dir(fileLocation) > "") 2038 | End Function 2039 | Public Function FileThere(ByVal fileLocation As String) As Boolean 2040 | '// DEPRECIATED - 6/5/2012 2041 | FileThere = (Dir(fileLocation) > "") 2042 | End Function 2043 | Public Function GetBoiler(ByVal sFile As String) As String 2044 | Dim fso As Object 2045 | Dim ts As Object 2046 | Set fso = CreateObject("Scripting.FileSystemObject") 2047 | Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2) 2048 | GetBoiler = ts.ReadAll 2049 | ts.Close 2050 | End Function 2051 | Public Function DivideText(ByVal txt As String, ByVal target1 As String, ByVal target2 As String) As String ', ByRef before As _ 2052 | String, ByRef between As String, ByRef after As String) 2053 | 2054 | 'Copied over from VendorProfilePriceSearch project on 5/21/2012 2055 | 2056 | Dim pos As Long 2057 | pos = InStr(txt, target1) 2058 | If pos = 0 Then Exit Function 2059 | 2060 | before = Left$(txt, pos - 1) 2061 | ' Remove up to target1 from the string. 2062 | txt = Mid$(txt, pos + Len(target1)) 2063 | 2064 | pos = InStr(txt, target2) 2065 | 'pos = 5 2066 | between = Left(txt, pos - 1) 2067 | ' Remove up to target2 from the string. 2068 | txt = Mid(txt, pos + Len(target2)) 2069 | ' Set between. 2070 | 2071 | ' Return what remains. 2072 | after = txt 2073 | 'Debug.Print between 2074 | 'Debug.Print txt 2075 | DivideText = between 2076 | Exit Function 2077 | 2078 | errhandler: 2079 | DivideText = "" 2080 | End Function 2081 | Public Sub waitForIE(ByVal IEObject As Object) 2082 | Do While IEObject.readyState <> 4 Or IEObject.busy = True 2083 | Loop 2084 | End Sub 2085 | Public Function RegKeyRead(ByVal i_RegKey As String) As String 2086 | Dim myWS As Object 2087 | 2088 | On Error Resume Next 2089 | Set myWS = CreateObject("WScript.Shell") 2090 | RegKeyRead = myWS.RegRead(i_RegKey) 2091 | End Function 2092 | Public Function RegKeyExists(i_RegKey As String) As Boolean 2093 | Dim myWS As Object 2094 | 2095 | On Error GoTo ErrorHandler 2096 | Set myWS = CreateObject("WScript.Shell") 2097 | myWS.RegRead i_RegKey 2098 | RegKeyExists = True 2099 | Exit Function 2100 | 2101 | ErrorHandler: 2102 | RegKeyExists = False 2103 | End Function 2104 | Public Sub RegKeySave(i_RegKey As String, _ 2105 | i_Value As String, _ 2106 | Optional i_Type As String = "REG_SZ") 2107 | Dim myWS As Object 2108 | 2109 | Set myWS = CreateObject("WScript.Shell") 2110 | myWS.RegWrite i_RegKey, i_Value, i_Type 2111 | 2112 | End Sub 2113 | Public Function RegKeyDelete(i_RegKey As String) As Boolean 2114 | Dim myWS As Object 2115 | 2116 | On Error GoTo ErrorHandler 2117 | Set myWS = CreateObject("WScript.Shell") 2118 | myWS.RegDelete i_RegKey 2119 | RegKeyDelete = True 2120 | Exit Function 2121 | 2122 | ErrorHandler: 2123 | RegKeyDelete = False 2124 | End Function 2125 | Private Function IsTime(sTime As String) As Boolean 2126 | 2127 | 'http://www.freevbcode.com/ShowCode.Asp?ID=1321 2128 | 'by Phil Fresle 2129 | 2130 | If Left(Trim(sTime), 1) Like "#" Then 2131 | IsTime = IsDate(Date & " " & sTime) 2132 | End If 2133 | End Function 2134 | Public Sub DeleteLineItem(ByVal ws As Worksheet, ByVal fieldName As String, Optional ByVal serviceStr1 As String, Optional ByVal serviceStr2 As String, Optional ByVal serviceStr3 As String, Optional ByVal deleteAnyNonBlank As Boolean) 2135 | '// Deletes entire entries that contain keywords specified by the user. Up to three unique keywords are supported. 2136 | 2137 | '*** Authored by Nathan N on 1/20/2012 *** 2138 | '*** Update by Nathan N on 2/2/2012 at 11:25AM - Added multiple string capability 2139 | '*** - Added fieldName capability 2140 | '// Updated 6/28/2012 by Nathan N: Changed structure for efficiency. Also added clause that exited the function more efficiently as well. Also added ability to delete blank entries or Non Blank Entries. 2141 | 2142 | Dim inverseRowNum As Long, origRowCount As Long, serviceColNum As Integer, delCount As Long 2143 | Dim currentService As String 2144 | Dim startRow As Long, endRow As Long 2145 | Dim i As Long 2146 | 2147 | Application.ScreenUpdating = False 2148 | 2149 | serviceStr1 = LCase(serviceStr1) 2150 | serviceStr2 = LCase(serviceStr2) 2151 | serviceStr3 = LCase(serviceStr3) 2152 | fieldName = LCase(fieldName) 2153 | 2154 | origRowCount = lastRow(ws) 2155 | serviceColNum = FieldColNum(ws, fieldName) 2156 | 2157 | If deleteAnyNonBlank = True Then 2158 | SortCol ws, fieldName 2159 | If ws.Cells(2, FieldColNum(ws, fieldName)) = "" Then 2160 | Debug.Print "Function DeleteLineItem: No Non-Blank Entries found" 2161 | Exit Sub 2162 | End If 2163 | startRow = 2 2164 | endRow = lastRow(ws, , FieldColNum(ws, fieldName)) 2165 | ws.Rows(startRow & ":" & endRow).Delete 2166 | Exit Sub 2167 | End If 2168 | 2169 | '// Delete Blank Entries 2170 | If serviceStr1 = "" Then 2171 | SortCol ws, fieldName 2172 | startRow = lastRow(ws, , FieldColNum(ws, fieldName)) + 1 2173 | endRow = lastRow(ws) 2174 | 2175 | If startRow = endRow + 1 Then '// if no blank entry was found then exit function 2176 | Debug.Print "Function DeleteLineItem: No Blank Entries detected" 2177 | Exit Sub 2178 | End If 2179 | 2180 | ws.Rows(startRow & ":" & endRow).Delete 2181 | Exit Sub 2182 | End If 2183 | 2184 | '// One service to be deleted 2185 | If (serviceStr1 <> "" And serviceStr2 = "" And serviceStr3 = "") Then 2186 | 2187 | For i = 2 To origRowCount 2188 | If i > origRowCount - delCount Then Exit Sub '// This ensures that the function exits as soon as it reaches the NEW last row after all the deletions 2189 | currentService = LCase(ws.Cells(i, serviceColNum)) 2190 | If currentService Like "*" & serviceStr1 & "*" Then 2191 | ws.Rows(i).Delete Shift:=xlUp 2192 | i = i - 1 2193 | delCount = delCount + 1 2194 | GoTo NextEntry1 2195 | End If 2196 | NextEntry1: 2197 | Next i 2198 | 2199 | '// Two Services to be Deleted 2200 | ElseIf (serviceStr1 <> "" And serviceStr2 <> "" And serviceStr3 = "") Then 2201 | 2202 | For i = 2 To origRowCount 2203 | If i > origRowCount - delCount Then Exit Sub 2204 | currentService = LCase(ws.Cells(i, serviceColNum)) 2205 | If (currentService Like "*" & serviceStr1 & "*") _ 2206 | Or (currentService Like "*" & serviceStr2 & "*") Then 2207 | ws.Rows(i).Delete Shift:=xlUp 2208 | i = i - 1 2209 | delCount = delCount + 1 2210 | GoTo NextEntry2 2211 | End If 2212 | NextEntry2: 2213 | Next i 2214 | 2215 | '// Three Services to be Deleted 2216 | ElseIf (serviceStr1 <> "" And serviceStr2 <> "" And serviceStr3 <> "") Then 2217 | 2218 | For i = 2 To origRowCount 2219 | If i > origRowCount - delCount Then Exit Sub 2220 | currentService = LCase(ws.Cells(i, serviceColNum)) 2221 | If currentService Like "*" & serviceStr1 & "*" _ 2222 | Or currentService Like "*" & serviceStr2 & "*" _ 2223 | Or currentService Like "*" & serviceStr3 & "*" Then 2224 | ws.Rows(i).Delete Shift:=xlUp 2225 | i = i - 1 2226 | delCount = delCount + 1 2227 | GoTo NextEntry3 2228 | End If 2229 | NextEntry3: 2230 | Next i 2231 | 2232 | End If 2233 | 2234 | End Sub 2235 | Sub DeleteMultiLineItem(ByVal ws As Worksheet, ByVal fieldName1 As String, ByVal fieldName2 As String, ByVal entryStr1 As String, ByVal entryStr2 As String) 2236 | '*** authored by Nathan N on 2/13/2012*** 2237 | 2238 | Dim inverseRowNum As Long, origRowCount As Long, serviceColNum As Integer 2239 | Dim currentEntry1 As String, currentEntry2 As String 2240 | Dim i As Long 2241 | 2242 | entryStr1 = LCase(entryStr1) 2243 | entryStr2 = LCase(entryStr2) 2244 | 2245 | fieldName1 = LCase(fieldName1) 2246 | fieldName2 = LCase(fieldName2) 2247 | 2248 | origRowCount = ws.Range("A" & Rows.Count).End(xlUp).Row 2249 | entryColNumA = FieldColNum(ws, fieldName1) 2250 | entryColNumB = FieldColNum(ws, fieldName2) 2251 | 2252 | For i = 2 To lastRow(ws) 2253 | 2254 | inverseRowNum = origRowCount - i + 2 2255 | 'Debug.Print inverseRowNum 2256 | currentEntry1 = LCase(ws.Cells(inverseRowNum, entryColNumA)) 2257 | currentEntry2 = LCase(ws.Cells(inverseRowNum, entryColNumB)) 2258 | 2259 | If (entryStr1 <> "" And entryStr2 <> "") Then 2260 | If (currentEntry1 Like "*" & entryStr1 & "*") _ 2261 | And (currentEntry2 Like "*" & entryStr2 & "*") Then 2262 | ws.Rows(inverseRowNum).Delete Shift:=xlUp 2263 | End If 2264 | End If 2265 | 2266 | Next i 2267 | End Sub 2268 | 2269 | 2270 | Public Function loginName() As String 2271 | '*** Authored by Hogan K in 2010 *** 2272 | '*** Updated on 1/31/2012 by Nathan N - Changed main variables and removed parameter "i_RegKey" in order to include in the main function 2273 | '*** UPdated on 4/26/2012 by Nathan N - Simplified everything. 2274 | 2275 | loginName = Environ("username") 2276 | 2277 | End Function 2278 | Public Sub DeleteOtherRecords(ByVal ws As Worksheet, ByVal fieldName As String, ByVal entryToKeep1 As String, Optional ByVal entryToKeep2 As String, Optional ByVal entryToKeep3 As String) 2279 | 'Created on 3/14/2012 by Nathan N 2280 | '*** Deletes all other records except for the those containing the entryToKeep *** 2281 | '*** Updated on 5/16/2012 by Nathan N: added "If endRow = -1" conditional to exit sub if desired entry to keep is not found. 2282 | '*** added "If (startRow > endRow) Then Exit Sub" due to a miscalc that deleted the last entry if the entryToKeep was not found 2283 | Dim i As Long 2284 | Dim startRow As Long, endRow As Long 2285 | 2286 | SortCol ws, fieldName 2287 | 2288 | If (InStr(1, ws.Cells(2, FieldColNum(ws, fieldName)), entryToKeep1) <= 0) Then 2289 | startRow = 2 2290 | endRow = FieldRowNum(ws, entryToKeep1, FieldColNum(ws, fieldName), , , True) - 1 2291 | If endRow = -1 Then Debug.Print ("Function 'DeleteOtherRecord' did not find entryToKeep1: '" & entryToKeep1 & "'") 2292 | If endRow = -1 Then Exit Sub 2293 | ws.Rows(CStr(startRow) & ":" & CStr(endRow)).Delete Shift:=xlUp 2294 | Else 2295 | startRow = FieldRowNum(ws, entryToKeep1, FieldColNum(ws, fieldName), , , , True) + 1 2296 | endRow = lastRow(ws) 2297 | If (startRow > endRow) Then Exit Sub 2298 | ws.Rows(CStr(startRow) & ":" & CStr(endRow)).Delete Shift:=xlUp 2299 | Exit Sub 2300 | End If 2301 | 2302 | If (InStr(1, LCase(ws.Cells(lastRow(ws), FieldColNum(ws, fieldName))), LCase(entryToKeep1)) <= 0) Then 2303 | startRow = FieldRowNum(ws, entryToKeep1, FieldColNum(ws, fieldName), , , , True) + 1 2304 | endRow = lastRow(ws) 2305 | ws.Rows(CStr(startRow) & ":" & CStr(endRow)).Delete Shift:=xlUp 2306 | End If 2307 | 2308 | End Sub 2309 | Public Function DirExists(ByVal directoryPath As String) As Boolean 2310 | '**Authored by Nathan N 2/16/2012 ** 2311 | If Len(Dir(directoryPath, vbDirectory)) = 0 Then 2312 | DirExists = False 2313 | Else 2314 | DirExists = True 2315 | End If 2316 | End Function 2317 | Public Sub CreateDir(ByVal directoryPath As String) 2318 | '// Created by Nathan N on 4/25/2012 2319 | '--- Create a new directory if none was present--- 2320 | 2321 | If (DirExists(directoryPath) = False) Then MkDir (directoryPath) 2322 | 2323 | End Sub 2324 | Public Sub emsg(ByVal moduleName As String, ByVal functionName As String, Optional ByVal addDebugErrMsg As String, Optional ByVal progName As String, Optional emailAdmin As Boolean, Optional ByVal emailUser As Boolean, Optional ByVal adminEmail As String, Optional ByVal quitProgram As Boolean, Optional ByVal wbQuit1 As Workbook, Optional ByVal wbQuit2 As Workbook, Optional ByVal wbQuit3 As Workbook, Optional ByVal wsQuit As Worksheet) 2325 | '// Created by Nathan N on 6/13/2012 2326 | '// Provides a way to notify people of errors and quit program in a more controlled manner, instead of suddenly 'breaking' 2327 | Dim adminFirstName As String 2328 | Dim adminErrMsg As String, userErrMsg As String 2329 | 2330 | Debug.Print ("There was an error in the program workbook '" & ThisWorkbook.Name & "', module '" & moduleName & "', function '" & functionName & "'.") 2331 | If addDebugErrMsg <> "" Then Debug.Print (addDebugErrMsg) 2332 | If quitProgram = True Then Debug.Print ("Program Quit.") 2333 | 2334 | If progName = "" Then 2335 | programName = ThisWorkbook.Name & " program" 2336 | Else 2337 | progName = progName & " program" 2338 | End If 2339 | If adminEmail = "" Then 2340 | adminEmail = "someone who can help" 2341 | adminFirstName = "Hello" 2342 | Else 2343 | adminFirstName = FirstName(Left(adminEmail, InStr(1, adminEmail, "@"))) 2344 | End If 2345 | '---------------------------------------------------------------------------------------------------------------- 2346 | '// Set message template to admin and / or user 2347 | If (quitProgram = True) Then 2348 | adminErrMsg = "

" & adminFirstName & ",
User " & loginName() & " experienced an error in " & functionName & " function in the " & moduleName & " module while running the " & progName & " within the " & ThisWorkbook.Name & " workbook. I've quit the program to avoid additional errors.

Please address at your earliest convenience.

Your Favorite,
Report Robot" 2349 | userErrMsg = "

Hello " & FirstName() & ",

I experienced a problem with the " & progName & " you're trying to run. I've quit the program to avoid additional errors.

Please contact " & adminEmail & " at your earliest convenience.

Your Favorite,
Report Robot" 2350 | ElseIf (quitProgram = False) Then 2351 | adminErrMsg = "

" & adminFirstName & ",
User " & loginName() & " experienced an error in " & functionName & " function in the " & moduleName & " module while running the " & progName & " within the " & ThisWorkbook.Name & " workbook. I tried to keep running the program, so it may or may not work out.

Please address at your earliest convenience.

Your Favorite,
Report Robot" 2352 | userErrMsg = "

Hello " & FirstName() & ",

I experienced a problem with the " & progName & " you're trying to run. I tried to keep running the program, so it may or may not work out.

Please contact " & adminEmail & " at your earliest convenience.

Your Favorite,
Report Robot" 2353 | End If 2354 | 2355 | '// Send message to admin and / or user 2356 | If emailAdmin = True Then EmailWhoever adminEmail, , "Report Robot Error: " & ThisWorkbook.Name & " Workbook", , , adminErrMsg 2357 | If emailUser = True Then EmailWhoever loginName() & "@domains.com", , "Report Robot Had an Error: " & progName, , , userErrMsg 2358 | 2359 | If quitProgram = True Then 2360 | Application.DisplayAlerts = False 2361 | If Not (wbQuit1 Is Nothing) Then wbQuit1.Close 2362 | If Not (wbQuit2 Is Nothing) Then wbQuit2.Close 2363 | If Not (wbQuit3 Is Nothing) Then wbQuit3.Close 2364 | If Not (wsQuit Is Nothing) Then wsQuit.Delete 2365 | End '// Ends subroutine 2366 | End If 2367 | 2368 | End Sub 2369 | Public Sub splitzips(ByVal ws As Worksheet, ByVal zipFieldName As String, Optional ByVal deleteExtraFields As Boolean) 2370 | '// Transfers comma seperated zip codes into their own cell. This is needed because an automated 'text-to-columns' typically does not 2371 | '// support the number of columns required to do this process 2372 | '// Authored by Nathan N on 6/14/2012 2373 | Dim i As Long, j As Long 2374 | Dim zipCol As Integer 2375 | Dim zipList() As String 2376 | Dim zipCount As Long 2377 | Dim rng As Range 2378 | 2379 | '// Deletes fields I thought were not needed for my purposes 2380 | If deleteExtraFields = True Then 2381 | If FieldExists(ws, "Insurance") Then ws.Columns(FieldColNum(ws, "Insurance", , True)).Delete 2382 | If FieldExists(ws, "Services") Then ws.Columns(FieldColNum(ws, "Services", , True)).Delete 2383 | If FieldExists(ws, "Mailing") Then ws.Columns(FieldColNum(ws, "Mailing", , True)).Delete 2384 | If FieldExists(ws, "Physical") Then ws.Columns(FieldColNum(ws, "Physical", , True)).Delete 2385 | End If 2386 | 2387 | zipCol = FieldColNum(ws, "Coverage", , True) 2388 | 2389 | For i = 2 To lastRow(ws) 2390 | If ws.Cells(i, zipCol) = "" Then GoTo NextItem '// prevents strange errors from occuring 2391 | If InStr(1, ws.Cells(i, zipCol), ",") < 1 Then GoTo NextItem '// prevents strange errors from occuring 2392 | zipList = Split(ws.Cells(i, zipCol), ", ") 2393 | zipCount = Application.WorksheetFunction.CountA(zipList) 2394 | ws.Range(ws.Cells(i, zipCol), ws.Cells(i, zipCount)) = Split(ws.Cells(i, zipCol), ",") 2395 | Set rng = ws.Range(ws.Cells(i, zipCol), ws.Cells(i, lastColNum(ws, i))) 2396 | rng.value = rng.value 2397 | Set rng = Nothing 2398 | ReDim zipList(0) 2399 | NextItem: 2400 | Next i 2401 | 2402 | End Sub 2403 | Public Sub deleteColRange(ByVal startCol As Integer, ByVal endCol As Integer) 2404 | '// Enables the deletion by range numbers, otherwise columns have to be deleted one-by-one, 2405 | '// or using letters, which is rather inconvenient. 2406 | '// Authored by Nathan N on 4.18.2014 2407 | 2408 | Dim colArray As Variant 2409 | Dim colRange As Range 2410 | Dim rangeIter As Integer 2411 | Dim i As Long 2412 | 2413 | colArray = "" 2414 | rangeIter = endCol - startCol 2415 | 2416 | For i = 0 To rangeIter 2417 | colArray = colArray & Str(startCol + i) & "," 2418 | Next i 2419 | 2420 | colArray = Left(colArray, Len(colArray) - 1) 2421 | colArray = Split(colArray, ",") 2422 | 2423 | Set colRange = Columns(colArray(0)) 2424 | For i = 1 To UBound(colArray) 2425 | Set colRange = Union(colRange, Columns(colArray(i))) 2426 | Next i 2427 | 2428 | colRange.Delete Shift:=xlToLeft 2429 | 2430 | End Sub 2431 | Public Sub listifyAndJsonify() 2432 | '// Turns two rows of data into a List (array) and JSON formatted data 2433 | '// i.e. [{"City":"San Jose, "Lat":0.3,"Lon":1.4},{"City":"Austin","Lat":0.5, "Lon":11.1}] 2434 | '/ Output will be on the first row of the third column: cell(1,3) 2435 | '// This function must be run from the VBA IDE. 2436 | 2437 | Dim wb As Workbook 2438 | Dim ws As Worksheet 2439 | Dim wbName As String, wsName As String 2440 | Dim key0 As String, key1 As String 2441 | Dim value0 As String, value1 As String 2442 | Dim s As String 2443 | Dim i As Long 2444 | 2445 | 2446 | 2447 | key = "" 2448 | s = "" 2449 | 2450 | While wbName = "" 2451 | workbookname: 2452 | wbName = "" 2453 | wbName = InputBox("Workbook name?") 2454 | Wend 2455 | 2456 | On Error GoTo workbookname 2457 | Set wb = Workbooks(wbName) 2458 | On Error GoTo 0 2459 | 2460 | While wsName = "" 2461 | wsName = "" 2462 | wsName = InputBox("Sheet Name?") 2463 | If Not SheetExists(wb, wsName) Then 2464 | wsName = "" 2465 | End If 2466 | Wend 2467 | While key0 = "" 2468 | key0 = InputBox("Key0 name?") 2469 | Wend 2470 | While key1 = "" 2471 | key1 = InputBox("Key1 name?") 2472 | Wend 2473 | 2474 | 2475 | 2476 | 2477 | Set ws = wb.Worksheets(wsName) 2478 | 2479 | 2480 | If VarType(ws.Cells(2, 2)) = vbDouble Then 2481 | quoteString = "" 2482 | Else 2483 | quoteString = """" 2484 | End If 2485 | 2486 | For i = 2 To lastRow(ws) 2487 | value0 = ws.Cells(i, 1) 2488 | value1 = ws.Cells(i, 2) 2489 | s = s & "{" & """" & key0 & """" & ":" & """" & value0 & """" & "," & """" & key1 & """" & ":" & quoteString & value1 & quoteString & "}," 2490 | Next i 2491 | 2492 | '// Remove the extra comma at the end of the string 2493 | s = Left(s, Len(s) - 1) 2494 | ws.Cells(1, 3) = "[" & s & "]" 2495 | 2496 | End Sub 2497 | Function Get_Variable_Type(myVar) 2498 | 2499 | ' --------------------------------------------------------------- 2500 | ' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com 2501 | ' --------------------------------------------------------------- 2502 | 2503 | If VarType(myVar) = vbNull Then 2504 | MsgBox "Null (no valid data) " 2505 | ElseIf VarType(myVar) = vbInteger Then 2506 | MsgBox "Integer " 2507 | ElseIf VarType(myVar) = vbLong Then 2508 | MsgBox "Long integer " 2509 | ElseIf VarType(myVar) = vbSingle Then 2510 | MsgBox "Single-precision floating-point number " 2511 | ElseIf VarType(myVar) = vbDouble Then 2512 | MsgBox "Double-precision floating-point number " 2513 | ElseIf VarType(myVar) = vbCurrency Then 2514 | MsgBox "Currency value " 2515 | ElseIf VarType(myVar) = vbDate Then 2516 | MsgBox "Date value " 2517 | ElseIf VarType(myVar) = vbString Then 2518 | MsgBox "String " 2519 | ElseIf VarType(myVar) = vbObject Then 2520 | MsgBox "Object " 2521 | ElseIf VarType(myVar) = vbError Then 2522 | MsgBox "Error value " 2523 | ElseIf VarType(myVar) = vbBoolean Then 2524 | MsgBox "Boolean value " 2525 | ElseIf VarType(myVar) = vbVariant Then 2526 | MsgBox "Variant (used only with arrays of variants) " 2527 | ElseIf VarType(myVar) = vbDataObject Then 2528 | MsgBox "A data access object " 2529 | ElseIf VarType(myVar) = vbDecimal Then 2530 | MsgBox "Decimal value " 2531 | ElseIf VarType(myVar) = vbByte Then 2532 | MsgBox "Byte value " 2533 | ElseIf VarType(myVar) = vbUserDefinedType Then 2534 | MsgBox "Variants that contain user-defined types " 2535 | ElseIf VarType(myVar) = vbArray Then 2536 | MsgBox "Array " 2537 | Else 2538 | MsgBox VarType(myVar) 2539 | End If 2540 | 2541 | End Function 2542 | --------------------------------------------------------------------------------