├── GetBrowserDefaultDownloadsPath ├── README.md ├── MacroSPEAK ├── GetMergedCellValue ├── CheckClearAutofilter ├── IsDateExcelFormula ├── ClipboardAlgos ├── DynamicArraySample ├── CheckVBAVersion ├── ClearAllActiveX ├── SetDirectoryForFileSelect ├── CloseWorkbookLoop ├── DeleteNSheets ├── GetUserName ├── CloseIEInstanceAll ├── SelectMultipleShapes ├── ServerGetOpenFilename ├── DynamicInsertRow ├── ReplaceInvalidNaming ├── UpdateComboboxWithoutTriggeringChange ├── SAPControlGridView ├── DynamicColumnRemoveDuplicate ├── ExportToCSV ├── ClearAllFields ├── ToggleQueriesAndConnectionsPane ├── FilteredRange ├── CalculateTimeElapsed ├── AllEnvironVariables ├── ArrayHasDuplicateValues ├── CutCopyPasteIntercept ├── LastCellAddress ├── ReadTextFileWithVBA ├── GetFirstLastDateInQtr ├── DynamicDataValidation ├── ArrayDistinctValues ├── SharePointLoopThroughFilesInFolder ├── AddNewCol ├── GetAllSheetInWorkbook ├── GetDate ├── SharePointSelectFile ├── FindAllFilesInFolder ├── SelfUpdatingDataValidationList ├── LockedSheetBruteForce ├── CopyMultipleSheetsNewWorkbook ├── RefreshDataConnection ├── SendEmailViaVBAMethod3 ├── GetFilteredRangeTopBtmRows ├── SearchForHTML ├── DeleteXSheets ├── ColorizeCells ├── SQLInsertToDBViaVBA ├── SQLDisplayDataFromDBViaVBA ├── FindInFolderMoveAndRename ├── SAPConnectFromVBA ├── SAPControlGridViewWithFindFunction ├── ClickIE11SaveButton ├── TransferModuleAcrossWorkbook ├── QueryCSVWithSQLinVBA ├── StringIncrementer ├── PivotTableSample1 ├── GetLineNumLargeFile ├── ConvertRangetoHTML ├── ExtractNumber ├── SQLRunStoredProcedureViaVBA ├── CheckAll ├── MakeTableBorder ├── PivotTableSample2 ├── UsefulSheetCodes ├── ArrayInitializedCheck ├── RangeSelector ├── FindKeyStringInAllFilesInFolder ├── ConvertExcelRangeToImageViaVBA ├── UpdateOrClear ├── SendEmailViaVBAMethod1 ├── SearchFor ├── ExplodeStrings ├── MultipleSelectMergeWorkbook ├── ArrayContainsMatch ├── VBA_OPTIMIZATION_README ├── SAPGroupedAlgos ├── SendEmailViaVBAMethod2 └── SendEmailViaVBAMethod4 /GetBrowserDefaultDownloadsPath: -------------------------------------------------------------------------------- 1 | a = Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Downloads" 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Excel_Macro_References 2 | Collection of useful Excel functions and subs written in VBA 3 | -------------------------------------------------------------------------------- /MacroSPEAK: -------------------------------------------------------------------------------- 1 | 'This command outputs a synthesized voice for any input pushed in. 2 | Application.Speech.Speak "Test" 3 | -------------------------------------------------------------------------------- /GetMergedCellValue: -------------------------------------------------------------------------------- 1 | sTargVal = Cells(a, b).MergeArea.Cells(1, 1).Value 'Where a and b are any cells within the merged cell range 2 | -------------------------------------------------------------------------------- /CheckClearAutofilter: -------------------------------------------------------------------------------- 1 | If ActiveSheet.AutoFilterMode = True Then 2 | ActiveSheet.ShowAllData 3 | ActiveSheet.AutoFilterMode = False 4 | End If 5 | -------------------------------------------------------------------------------- /IsDateExcelFormula: -------------------------------------------------------------------------------- 1 | Public Function IDATE(ByVal inputString As String) As Boolean 2 | 'custom user defined vba function for use as formula 3 | IDATE = IsDate(inputString) 4 | End Function 5 | -------------------------------------------------------------------------------- /ClipboardAlgos: -------------------------------------------------------------------------------- 1 | Dim clipboard As New MSForms.DataObject 2 | 3 | clipboard.SetText ThisWorkbook.Sheets("Macro").TextBox1.Value 4 | clipboard.PutInClipboard 5 | 6 | clipboard.GetFromClipboard 7 | strcontents = clipboard.GetText 8 | -------------------------------------------------------------------------------- /DynamicArraySample: -------------------------------------------------------------------------------- 1 | Public Sub test1() 2 | 3 | Dim a() As String 4 | ReDim Preserve a(0 To 0) As String 5 | 6 | Count = 0 7 | 8 | For i = 0 To 10 9 | a(Count) = i 10 | Count = Count + 1 11 | ReDim Preserve a(0 To Count) As String 12 | Next i 13 | 14 | End Sub 15 | -------------------------------------------------------------------------------- /CheckVBAVersion: -------------------------------------------------------------------------------- 1 | Public Sub CheckVBA() 2 | 3 | #If VBA7 Then 4 | MsgBox "VBA 7" 5 | #Else 6 | MsgBox "VBA < 7" 7 | #End If 8 | 9 | #If Win64 Then 10 | ' Win64=true, Win32=true, Win16= false 11 | #ElseIf Win32 Then 12 | ' Win32=true, Win16=false 13 | #Else 14 | ' Win16=true 15 | #End If 16 | 17 | End Sub 18 | -------------------------------------------------------------------------------- /ClearAllActiveX: -------------------------------------------------------------------------------- 1 | Public Sub clearAll() 2 | 3 | 'this Sub clears all of the ActiveX objects present on the sheet 4 | 5 | For i = 1 To 8 6 | ThisWorkbook.Sheets("Macro").OLEObjects("TextBox" & i).Object.Value = "" 7 | If i <= 5 Then 8 | ThisWorkbook.Sheets("Macro").OLEObjects("ComboBox" & i).Object.Value = "" 9 | End If 10 | Next i 11 | 12 | End Sub 13 | -------------------------------------------------------------------------------- /SetDirectoryForFileSelect: -------------------------------------------------------------------------------- 1 | 'library code to allow GetOpenFile to go directly to server filepath 2 | #If VBA7 Then 3 | Declare PtrSafe Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As LongPtr 4 | #Else 5 | Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long 6 | #End If 7 | -------------------------------------------------------------------------------- /CloseWorkbookLoop: -------------------------------------------------------------------------------- 1 | Public Sub CloseWorkbookLoop(ByVal sTargWBName As String) 2 | 3 | 'this sub loops through all of the open workbooks in Excel, looks for and closes the workbook specified in sTargWBName 4 | Dim openWBs As Workbook 5 | 6 | For Each openWBs In Workbooks 7 | If openWBs.Name = sTargWBName Then 8 | openWBs.Close savechanges:=False 9 | End If 10 | Next 11 | 12 | End Sub 13 | -------------------------------------------------------------------------------- /DeleteNSheets: -------------------------------------------------------------------------------- 1 | Public Sub DeleteSheets(Optional iShCnt As Integer = 1) 2 | 3 | 'this function clears all of the sheets after the variable amount 4 | 5 | If Sheets.Count > iShCnt Then 6 | For i = Sheets.Count To iShCnt + 1 Step -1 7 | Application.DisplayAlerts = False 8 | Sheets(i).Delete 9 | Application.DisplayAlerts = True 10 | Next i 11 | End If 12 | 13 | End Sub 14 | -------------------------------------------------------------------------------- /GetUserName: -------------------------------------------------------------------------------- 1 | ' Referenced from : https://officetricks.com/excel-vba-get-username-windows-system/ 2 | ' This code helps get the current logged on User's ID or Username, depending on how your computer is set up by you/your admin 3 | 4 | a = Environ$("username") 'Returns user ID 5 | b = Environ("Username") 'Returns user ID 6 | c = Application.UserName 'Returns user name (for corporate accounts, it seems to follow Skype for Business format) 7 | -------------------------------------------------------------------------------- /CloseIEInstanceAll: -------------------------------------------------------------------------------- 1 | Public Sub IE_Sledgehammer() 2 | Dim objWMI As Object, objProcess As Object, objProcesses As Object 3 | Set objWMI = GetObject("winmgmts://.") 4 | Set objProcesses = objWMI.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'iexplore.exe'") 5 | For Each objProcess In objProcesses 6 | Call objProcess.Terminate 7 | Next 8 | Set objProcesses = Nothing: Set objWMI = Nothing 9 | End Sub 10 | -------------------------------------------------------------------------------- /SelectMultipleShapes: -------------------------------------------------------------------------------- 1 | Public Sub SelectMultipleShapes() 2 | 3 | 'this sub selects multiple shapes by the name provided within the target sheet 4 | 5 | Dim objShape As Shape 6 | Dim i As Integer: i = 0 7 | Dim arrShapeNames() As String 8 | ReDim arrShapeNames(0 To 2) As String 9 | 10 | arrShapeNames(0) = "Oval1" 11 | arrShapeNames(1) = "Oval2" 12 | arrShapeNames(2) = "Oval3" 13 | 14 | Sheet1.Shapes.Range(arrShapeNames).Select 15 | 16 | End Sub 17 | -------------------------------------------------------------------------------- /ServerGetOpenFilename: -------------------------------------------------------------------------------- 1 | 'Method to use GetOpenFilename function for server filepath 2 | 3 | 'library code to allow GetOpenFile to go directly to server filepath 4 | Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long 5 | 6 | 'call method 7 | SetCurrentDirectory serverFilepath 8 | 9 | 'open workbook, goes directly to server filepath 10 | sFPth1 = Application.GetOpenFilename(, , "X Workbook Selection") 11 | -------------------------------------------------------------------------------- /DynamicInsertRow: -------------------------------------------------------------------------------- 1 | Public Sub DynamicInsertRow(ByVal TopRowAdd As String, ByVal NumOfRows As Long) 2 | 3 | 'This sub accepts two parameters: TopRowAdd and NumOfRows to dynamically add x 4 | 'amount of rows underneath the address provided in TopRowAdd address string 5 | 6 | 'Sample call : Call DynamicInsertRow(Cells(53, 1).Address, 2) 7 | 8 | Rows(Range(TopRowAdd).Row + 1 & ":" & Range(TopRowAdd).Row + NumOfRows).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 9 | 10 | End Sub 11 | -------------------------------------------------------------------------------- /ReplaceInvalidNaming: -------------------------------------------------------------------------------- 1 | Public Function ReplaceInvalidNaming(ByVal sInputString As String) As String 2 | 3 | 'Calling method: a = ReplaceInvalidNaming("Sample") 4 | 5 | Const sInvalidChars As String = "/\|<>:*?""" 6 | 7 | ReplaceInvalidNaming = sInputString 8 | 9 | For j = 1 To Len(sInvalidChars) 10 | If InStr(ReplaceInvalidNaming, Mid(sInvalidChars, j, 1)) <> 0 Then 11 | ReplaceInvalidNaming = Replace(ReplaceInvalidNaming, Mid(sInvalidChars, j, 1), "_") 12 | End If 13 | Next j 14 | 15 | End Function 16 | -------------------------------------------------------------------------------- /UpdateComboboxWithoutTriggeringChange: -------------------------------------------------------------------------------- 1 | 'These combination of subs allows for combobox updating without triggring the OnChange function 2 | 3 | Public bTriggerChange As Boolean 4 | 5 | Private Sub ComboBox2_DropButtonClick() 6 | bTriggerChange = True 7 | End Sub 8 | 9 | Private Sub ComboBox2_Change() 10 | If bTriggerChange = True And ComboBox2.Value <> -1 Then 11 | 'Whatever code to run once the selection is made, instead of when the combobox values is being updated 12 | bTriggerChange = False 13 | End If 14 | End Sub 15 | -------------------------------------------------------------------------------- /SAPControlGridView: -------------------------------------------------------------------------------- 1 | 'Code to get GridView values from SAP Shell. Getting Current Cell Row and Column depends on which cell is highlighted 2 | 'Function reference website included. 3 | 4 | a = session.findById("wnd[1]/usr/cntlGRID1/shellcont/shell").CurrentCellRow 5 | b = session.findById("wnd[1]/usr/cntlGRID1/shellcont/shell").CurrentCellColumn 6 | c = session.findById("wnd[1]/usr/cntlGRID1/shellcont/shell").GetCellValue(a, b) 7 | 8 | http://documentation.microfocus.com/help/index.jsp?topic=%2Fcom.borland.silktest.workbench.doc%2Flangref%2FSAP%2FSapGridViewClass_ref.html 9 | -------------------------------------------------------------------------------- /DynamicColumnRemoveDuplicate: -------------------------------------------------------------------------------- 1 | Dim avColArr() As Variant 2 | ReDim avColArr(0 To 0) As Variant 3 | 4 | lArrCtr = 0 5 | For i = ColumnStartRange To ColumnEndRange 6 | avColArr(lArrCtr) = lArrCtr + 1 7 | lArrCtr = lArrCtr + 1 8 | ReDim Preserve avColArr(0 To lArrCtr) As Variant 9 | Next i 10 | 11 | ReDim Preserve avColArr(0 To UBound(avColArr) - 1) As Variant 12 | ActiveSheet.Range(Cells(1,1),Cells(1,1)).RemoveDuplicates Columns:=(avColArr), Header:=xlNo 13 | 14 | 'reference: https://www.mrexcel.com/board/threads/removing-duplicates-dynamic-columns-vba.470729/ 15 | -------------------------------------------------------------------------------- /ExportToCSV: -------------------------------------------------------------------------------- 1 | Public Sub exportToCSV() 2 | 3 | 'references: 4 | '1. : http://learnexcelmacro.com/wp/2017/09/save-excel-range-data-as-csv-file-through-excel-vba/ 5 | '2. : https://stackoverflow.com/questions/8419828/how-to-create-a-separate-csv-file-from-vba 6 | 7 | Dim sFPathName As String 8 | Dim iFNum As Integer 9 | 10 | sFPathName = ThisWorkbook.Path & "\" & "CSV-Exported-File.csv" 11 | iFNum = FreeFile 'this is the actual CSV file declaration 12 | Open sFPathName For Output As #iFNum 13 | 14 | Print #iFNum, "test,test,test" 15 | 16 | Close #iFNum 17 | 18 | End Sub 19 | -------------------------------------------------------------------------------- /ClearAllFields: -------------------------------------------------------------------------------- 1 | Public Sub clearAllask() 2 | 3 | sure = MsgBox("Are you sure you want to clear the fields?", vbYesNo, "ATTENTION!") 4 | If sure = vbYes Then 5 | Call clearAll 6 | 'Call clearSheets 7 | Else 8 | MsgBox "Reset cancelled!" 9 | End If 10 | 11 | End Sub 12 | 13 | Public Sub clearAll() 14 | 15 | Dim aShFieldLoc(0 To 2) As String 16 | aShFieldLoc(0) = "C4" 17 | aShFieldLoc(1) = "G4" 18 | aShFieldLoc(2) = "K4" 19 | 20 | For i = 0 To UBound(aShFieldLoc) 21 | Range(aShFieldLoc(i)).Value = "" 22 | ThisWorkbook.Sheets("Macro").OLEObjects("ComboBox" & i + 1).Object.Value = "" 23 | Next i 24 | 25 | End Sub 26 | -------------------------------------------------------------------------------- /ToggleQueriesAndConnectionsPane: -------------------------------------------------------------------------------- 1 | 'This code toggles the queries and connections pane for a quick visual indicator on what queries are refreshing 2 | Public Sub ToggleQueriesAndConnections() 3 | 4 | 'invert display alert and screen updating suppressions 5 | Application.DisplayAlerts = Not (Application.DisplayAlerts) 6 | Application.ScreenUpdating = Not (Application.ScreenUpdating) 7 | 8 | With Application.CommandBars("Queries and Connections") 9 | .Visible = Not (.Visible) 10 | .Position = msoBarRight 'this line just keeps the command bar to the right, but is critical. Without this, the width line for some reason doesn't work. 11 | .Width = 500 12 | End With 13 | 14 | End Sub 15 | -------------------------------------------------------------------------------- /FilteredRange: -------------------------------------------------------------------------------- 1 | Public Function filteredRange(ByVal startFRRow As Long, ByVal startFRCol As Integer, ByVal endFRRow As Long, ByVal endFRCol As Integer) As Range 2 | 'sub tries to handle the shortcomings of the specialcells(xlcelltypevisible) method that fails when filter only produces one line of results 3 | 'sub checks for amount of lines in the filter result before choosing the appropriate FR method 4 | 5 | If startFRRow = endFRRow Then 6 | Set filteredRange = Range(Cells(startFRRow, startFRCol), Cells(endFRRow, endFRCol)) 7 | Else 8 | Set filteredRange = Range(Cells(startFRRow, startFRCol), Cells(endFRRow, endFRCol)).SpecialCells(xlCellTypeVisible) 9 | End If 10 | 11 | End Function 12 | -------------------------------------------------------------------------------- /CalculateTimeElapsed: -------------------------------------------------------------------------------- 1 | Sub CalculateTimeElapsed() 2 | 3 | 'This sub calculates the time it takes to run a code 4 | 5 | Dim dStart As Date 6 | Dim dDiff As Date 7 | Dim sTimePassed As String 8 | 9 | 'catch macro start time 10 | dStart = Now 11 | 12 | '*************************************************** 13 | '***************INSERT CODE HERE******************** 14 | '*************************************************** 15 | 16 | Application.Wait (Now + TimeValue("00:00:01")) 17 | dDiff = Now - dStart 18 | 19 | 'Determine how long code took to run 20 | sTimePassed = Format(dDiff, "hh:mm:ss") 21 | 22 | 'Notify user 23 | MsgBox "This code ran successfully in " & sTimePassed, vbInformation 24 | 25 | End Sub 26 | -------------------------------------------------------------------------------- /AllEnvironVariables: -------------------------------------------------------------------------------- 1 | Sub AllEnvironVariables() 2 | 3 | 'reference website : https://wellsr.com/vba/2019/excel/list-all-environment-variables-with-vba-environ/ 4 | 'Make sure to run in a new clear sheet 5 | 6 | Dim strEnviron As String 7 | Dim VarSplit As Variant 8 | Dim i As Long 9 | 10 | For i = 1 To 255 11 | strEnviron = Environ$(i) 12 | If LenB(strEnviron) = 0& Then GoTo TryNext: 13 | VarSplit = Split(strEnviron, "=") 14 | If UBound(VarSplit) > 1 Then Stop 15 | Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).Value = i 16 | Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1).Value = VarSplit(0) 17 | Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1).Value = VarSplit(1) 18 | TryNext: 19 | Next 20 | 21 | End Sub 22 | -------------------------------------------------------------------------------- /ArrayHasDuplicateValues: -------------------------------------------------------------------------------- 1 | ' Returns True if an array contains duplicate values 2 | ' it works with arrays of any type 3 | 4 | Function HasDuplicateValues(arr As Variant) As Boolean 5 | Dim col As Collection, index As Long 6 | Set col = New Collection 7 | 8 | ' assume that the array contains duplicates 9 | HasDuplicateValues = True 10 | 11 | On Error GoTo FoundDuplicates 12 | For index = LBound(arr) To UBound(arr) 13 | ' build the key using the array element 14 | ' an error occurs if the key already exists 15 | col.Add 0, CStr(arr(index)) 16 | Next 17 | ' if control comes here, the array doesn't contain 18 | ' any duplicate values, so we can return zero 19 | HasDuplicateValues = False 20 | 21 | FoundDuplicates: 22 | 23 | End Function 24 | -------------------------------------------------------------------------------- /CutCopyPasteIntercept: -------------------------------------------------------------------------------- 1 | Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) 2 | 3 | 'This sub allows devs to control what happens when users use the cut, copy or paste shortcuts 4 | 'Sub runs an interrupt everytime copy commands are called in the code as well. Something to be careful of. 5 | 'Needs to be placed in the ThisWorkbook Excel Objects section of your project 6 | 7 | Select Case Application.CutCopyMode 8 | Case Is = False 9 | 'do something 10 | Case Is = xlCopy 11 | 'do something 12 | Case Is = xlCut 13 | 'do something 14 | End Select 15 | 16 | 'Sample action: 17 | 'MsgBox "Please DO NOT Cut and Paste. Use Copy and Paste; then delete the source.", vbCritical, "WARNING!" 18 | 'Application.CutCopyMode = False 'clear clipboard and cancel cut 19 | 20 | End Sub 21 | -------------------------------------------------------------------------------- /LastCellAddress: -------------------------------------------------------------------------------- 1 | Public Function lastCellAdd() As String 2 | 3 | 'this function retrieves the row and column of the last most cell in the worksheet 4 | 5 | Dim lastColumn As Integer 6 | Dim lastRow As Long 7 | 8 | If WorksheetFunction.CountA(Cells) > 0 Then 9 | 'Search for any entry, by searching backwards by Rows. 10 | lastRow = Cells.Find(What:="*", after:=Cells(Rows.Count, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 11 | 'Search for any entry, by searching backwards by Columns. 12 | lastColumn = Cells.Find(What:="*", after:=Cells(1, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 13 | lastCellAdd = Cells(lastRow, lastColumn).Address(False, False) 14 | Else 15 | lastCellAdd = "X" 16 | End If 17 | 18 | End Function 19 | 20 | lLastRow = Cells(Rows.Count, 1).End(xlUp).Row 21 | lLastColumn = Cells(1, Columns.Count).End(xlToRight).Column 22 | -------------------------------------------------------------------------------- /ReadTextFileWithVBA: -------------------------------------------------------------------------------- 1 | 'This code reads the whole text file in one shot and can then parse the file line by line at your leisure. 2 | 'Useful when trying to loop through multiple text files to get a keyword from one of them for example 3 | 'Source: https://stackoverflow.com/questions/20128115/input-past-end-of-file-vba-excel 4 | 5 | 'Code: 6 | Sub Sample() 7 | Dim MyData As String, strData() As String 8 | Dim i As Long 9 | 10 | '~~> Replace your file here 11 | Open "C:\MyFile.Txt" For Binary As #1 12 | MyData = Space$(LOF(1)) 13 | Get #1, , MyData 14 | Close #1 15 | strData() = Split(MyData, vbCrLf) 16 | 17 | ' 18 | '~~> Now strData has all the data from the text file 19 | ' 20 | 21 | For i = LBound(strData) To UBound(strData) 22 | Debug.Print strData(i) 23 | ' 24 | '~~> What ever you want here 25 | ' 26 | Next i 27 | End Sub 28 | -------------------------------------------------------------------------------- /GetFirstLastDateInQtr: -------------------------------------------------------------------------------- 1 | Public Function LastDateInQtr(Optional checkDate As Date = 0) As Date 2 | 3 | 'Function returns the last day in the quarter based on date 4 | Const numOfMnthsInQtr As Integer = 3 5 | 6 | If checkDate = 0 Then 7 | 'use current date if no date passed in 8 | checkDate = Date 9 | End If 10 | 11 | LastDateInQtr = DateSerial(Year(checkDate), Int((Month(checkDate) - 1) / numOfMnthsInQtr) * numOfMnthsInQtr + (numOfMnthsInQtr + 1), 0) 12 | 13 | End Function 14 | 15 | Public Function FirstDateInQtr(Optional checkDate As Date = 0) As Date 16 | 17 | 'Function returns the first day in the quarter based on date 18 | Const numOfMnthsInQtr As Integer = 3 19 | 20 | If checkDate = 0 Then 21 | 'use current date if no date passed in 22 | checkDate = Date 23 | End If 24 | 25 | FirstDateInQtr = DateSerial(Year(checkDate), Int((Month(checkDate) - 1) / numOfMnthsInQtr) * numOfMnthsInQtr + 1, 1) 26 | 27 | End Function 28 | -------------------------------------------------------------------------------- /DynamicDataValidation: -------------------------------------------------------------------------------- 1 | 'This formula is applied into the data validation code for a cell, it takes the whole list from start to end as the options in the data validation dropdown. 2 | 'Start row can be specified, but last row will be automatically calculated because of the formula 3 | 'Formula to use is: =OFFSET(E1,0,0,COUNTA(E:E)) 4 | 'Where E1 is the start row of the data validation dropdown reference 5 | 'E:E is the column the dropdown data is in. It will take the last row value of this column and 6 | 'push in all values between the first row and the last row as the data validation option 7 | 8 | 'Sample VBA Code: 9 | With Cells(lTargRow, lTargCol).Validation 10 | .Delete 11 | .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ 12 | xlBetween, Formula1:="=OFFSET(E1,0,0,COUNTA(E:E))" 13 | .IgnoreBlank = True 14 | .InCellDropdown = True 15 | .InputTitle = "" 16 | .ErrorTitle = "" 17 | .InputMessage = "" 18 | .ErrorMessage = "" 19 | .ShowInput = True 20 | .ShowError = True 21 | End With 22 | -------------------------------------------------------------------------------- /ArrayDistinctValues: -------------------------------------------------------------------------------- 1 | Public Function ArrayDistinctValues(targRange As Range) As String() 2 | 3 | 'function accepts a range value, loops down range, pushes unique values within the range into an array 4 | 'and returns the array as a string array 5 | 6 | Dim rCell As Range 7 | Dim cUniqueVals As New Collection 8 | Dim iArrCnt As Integer 9 | Dim aUniqueVals() As String 10 | ReDim aUniqueVals(0 To 0) As String 11 | 12 | 'create a unique, no duplicate collection, push into an array 13 | For Each rCell In targRange 14 | If rCell.Row = 1 Then GoTo callNext 15 | On Error GoTo errHandler 16 | cUniqueVals.Add Trim(rCell.Value), Trim(CStr(rCell.Value)) 17 | aUniqueVals(iArrCnt) = rCell.Value 18 | iArrCnt = iArrCnt + 1 19 | ReDim Preserve aUniqueVals(0 To iArrCnt) As String 20 | 21 | errHandler: 22 | If Err.Number <> 0 Then 23 | Err.Number = 0 24 | End If 25 | Resume callNext 26 | 27 | callNext: 28 | Next rCell 29 | 30 | ArrayDistinctValues = aUniqueVals 31 | Set cUniqueVals = Nothing 32 | 33 | End Function 34 | -------------------------------------------------------------------------------- /SharePointLoopThroughFilesInFolder: -------------------------------------------------------------------------------- 1 | 'This sub loops through the files in a specified sharepoint folder. 2 | 'The folder address must be in the format specified otherwise VBA doesn't really like that. 3 | 4 | Sub SharePointLoopThroughFilesInFolder() 5 | 6 | Dim sSPPath As String 7 | Dim objFSO As Object 8 | Dim objFolder As Object 9 | Dim objFile As Object 10 | 11 | 'point to sharepoint folder that contains the files 12 | 'sharepoint path needs to be converted from "https://sharepoint drive/folder/another folder/another folder" to "//sharepoint drive/folder/another folder/another folder" 13 | sSPPath = "//sharepoint drive/folder/another folder/another folder" 14 | 15 | 'create File System Object 16 | Set objFSO = CreateObject("Scripting.FileSystemObject") 17 | 18 | 'Use FSO object to get the folder pointed at by the directory 19 | Set objFolder = objFSO.GetFolder(sSPPath) 20 | 21 | 'Loop through the files within the folder specified to get attributes 22 | For Each objFile In objFolder.Files 23 | a = objFile.Name 24 | Next 25 | 26 | End Sub 27 | 28 | -------------------------------------------------------------------------------- /AddNewCol: -------------------------------------------------------------------------------- 1 | 'Alternative single line dynamic code 2 | 'Code will add column to the left of the address, taking right cells as format 3 | 'A1 is the address of the cell to start adding columns to 4 | '3 is the number of columns to add 5 | [A1].Resize(, 3).EntireColumn.Insert 6 | Cells(1, 1).Resize(, 3).EntireColumn.Insert 7 | 8 | 'Call Method : 9 | a = addNewCol("A1", True) 10 | 'where a returns the address of the newly added column 11 | 12 | Public Function addNewCol(ByVal targAdd As String, Optional bLeftAdd As Boolean = False) As String 13 | 14 | 'this function adds a column to the left or right the target address provided, depending on the boolean flag indicator 15 | 16 | If bLeftAdd <> True Then 17 | 'insert a column to the right of the cell 18 | ActiveSheet.Range(targAdd).EntireColumn.Offset(0, 1).Insert 19 | addNewCol = Range(targAdd).Offset(0, 1).Address 20 | Else 21 | 'insert a column to the left of the cell 22 | ActiveSheet.Range(targAdd).EntireColumn.Insert 23 | addNewCol = Range(targAdd).Address 24 | End If 25 | 26 | End Function 27 | -------------------------------------------------------------------------------- /GetAllSheetInWorkbook: -------------------------------------------------------------------------------- 1 | 'XBrowse variables 2 | Public sFPth1 As String 3 | Public wbX As Workbook 4 | 5 | Public Sub XBrowse() 6 | 7 | Application.ScreenUpdating = False 8 | 9 | Set cmbBox = ThisWorkbook.Sheets("Macro").ComboBox1 10 | 11 | 'select and open X workbook 12 | sFPth1 = Application.GetOpenFilename(, , "X File Workbook Selection") 13 | If sFPth1 <> "" And sFPth1 <> "False" Then 14 | 'parse value into textbox 15 | ThisWorkbook.Sheets("Macro").Range("C10").Value = sFPth1 16 | 'open workbook, get sheet names 17 | Application.DisplayAlerts = False 18 | Set wbX = Workbooks.Open(sFPth1) 19 | Application.DisplayAlerts = True 20 | cmbBox.Clear 21 | 22 | 'get each sheet name from workbook and place into combo box 23 | For Each indSheet In wbX.Sheets 24 | cmbBox.AddItem indSheet.Name 25 | Next indSheet 26 | 27 | wbX.Close savechanges:=False 28 | 29 | Else 30 | MsgBox "No file selected. Please re-run the macro and try again." 31 | End 32 | End If 33 | 34 | Application.ScreenUpdating = False 35 | 36 | End Sub 37 | -------------------------------------------------------------------------------- /GetDate: -------------------------------------------------------------------------------- 1 | 'Public Function getDate(Optional selectedDate As Variant, Optional iDateSwitch As Integer = 1) As Date 2 | Public Function getDate(Optional selectedDate As Date, Optional iDateSwitch As Integer = 1) As Date 3 | 4 | 'this function has 2 different modes 5 | '1. Returns the Monday date of any given week based on the date 6 | '2. Returns the last date of any given month based on the date 7 | 'should there be no dates input as parameter, it will take current date 8 | 9 | If IsMissing(selectedDate) = True Then 10 | selectedDate = Date 11 | End If 12 | 13 | If iDateSwitch = 1 Then 14 | If Weekday(selectedDate) = 2 Then 15 | getDate = selectedDate 16 | ElseIf Weekday(selectedDate) > 2 Then 17 | getDate = selectedDate - (Weekday(selectedDate) - 2) 18 | ElseIf Weekday(selectedDate) < 2 Then 19 | getDate = selectedDate - 6 20 | 'getDate = selectedDate - (2 - Weekday(selectedDate)) '< If first day is Sunday 21 | End If 22 | ElseIf iDateSwitch = 2 Then 23 | getDate = DateSerial(Year(selectedDate), Month(selectedDate) + 1, 0) 24 | End If 25 | 26 | End Function 27 | -------------------------------------------------------------------------------- /SharePointSelectFile: -------------------------------------------------------------------------------- 1 | Public Function SharePointSelectFile(ByVal SharePointAddressString As String) As String 2 | 3 | 'This function opens sharepoint folder destination to allow user to select workbook within sharepoint folder 4 | 'function can be customized to point to sharepoint folder path and returns full selected workbook path 5 | 'if user cancels workbook selection, string will return "" 6 | 'Call method : FullSharePointWBAddress = SharePointSelectFile("Sharepoint folder directory") 7 | 8 | Dim wbFromSharePoint As Workbook 9 | Dim vrtSelectedItem As Variant 10 | Dim sSharePointDir As String 11 | 12 | sSharePointDir = SharePointAddressString 13 | 14 | 'use msoFileDialogOpen to link to Sharepoint folder 15 | With Application.FileDialog(msoFileDialogOpen) 16 | .InitialFileName = sSharePointDir & "\" 'SharePoint address variable here 17 | .AllowMultiSelect = False 'toggle multiple file(s) selection 18 | .Show 'calls fileselect userform 19 | 20 | For Each vrtSelectedItem In .SelectedItems 21 | Set SharePointSelectFile = vrtSelectedItem 22 | Next 23 | End With 24 | 25 | End Function 26 | -------------------------------------------------------------------------------- /FindAllFilesInFolder: -------------------------------------------------------------------------------- 1 | Public Function FindAllFilesInFolder(ByRef sTargetPath As String) As String() 2 | 3 | 'This functions gets into the specified folder, loops through all files and gets their names and pushes it all into an array 4 | 5 | Dim sDirectoryPath As String 6 | Dim fileSys As FileSystemObject 7 | Dim sFolderPath As Variant 8 | Dim objFile As File 9 | Dim lArrCtr As Long 10 | Dim asTemp() As String 11 | ReDim asTemp(0 To 0) As String 12 | 13 | 'set up filesys objects and set path for files - change for your folder 14 | 'sDirectoryPath = Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Downloads" 15 | sDirectoryPath = sTargetPath 'filepath here 16 | Set fileSys = New FileSystemObject 17 | Set sFolderPath = fileSys.GetFolder(sDirectoryPath) 18 | 19 | 'loop through each file and get name 20 | lArrCtr = 0 21 | For Each objFile In sFolderPath.Files 22 | asTemp(lArrCtr) = objFile.Name 23 | lArrCtr = lArrCtr + 1 24 | ReDim Preserve asTemp(0 To lArrCtr) As String 25 | Next objFile 26 | 27 | Set fileSys = Nothing 28 | Set sFolderPath = Nothing 29 | Set objFile = Nothing 30 | 31 | FindAllFilesInFolder = asTemp 32 | 33 | End Function 34 | -------------------------------------------------------------------------------- /SelfUpdatingDataValidationList: -------------------------------------------------------------------------------- 1 | Reference: https://www.ablebits.com/office-addins-blog/2015/02/11/excel-offset-function/ 2 | 3 | This method gets an self-updating range and last row of a column, useful for when you want an data validation list 4 | without having to prompt for a refresh constantly. 5 | 6 | To create a self updating data validation list using this method, follow these steps. 7 | 8 | 1. FORMULAS ribbon > Name Manager > New 9 | 2. Name the range to refer to in Data Validation later. Recommend to key in name without spacing: Test_Test 10 | 3. In the "Refers To" section, use this formula: =OFFSET(SheetName!$A$10,0,0,COUNTA(SheetName!$A:$A),1). 11 | Substitute "$A$10" with first row of target range and "$A:$A" with target range column. 12 | 4. Click "OK" 13 | 5. DATA ribbon > Data Validation 14 | 6. Allow = "List", Source = "=Test_Test" (Named range), Click "OK" 15 | 16 | NOTE: Naming the range is not necessary. Putting the formula directly into the Source field is fine too. 17 | 18 | Cell with data validation should now have a self updating list. When you add a new value in the list reference, 19 | the data validation should update itself too. 20 | -------------------------------------------------------------------------------- /LockedSheetBruteForce: -------------------------------------------------------------------------------- 1 | Sub LockedSheetBruteForce() 2 | 'Breaks worksheet password protection. 3 | Dim i As Integer, j As Integer, k As Integer 4 | Dim l As Integer, m As Integer, n As Integer 5 | Dim i1 As Integer, i2 As Integer, i3 As Integer 6 | Dim i4 As Integer, i5 As Integer, i6 As Integer 7 | 8 | On Error Resume Next 9 | 10 | For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 11 | For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 12 | For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 13 | For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 14 | ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ 15 | Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ 16 | Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 17 | 18 | If ActiveSheet.ProtectContents = False Then 19 | MsgBox "One usable password is " & Chr(i) & Chr(j) & _ 20 | Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ 21 | Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 22 | Exit Sub 23 | End If 24 | 25 | Next: Next: Next: Next: Next: Next 26 | Next: Next: Next: Next: Next: Next 27 | End Sub 28 | -------------------------------------------------------------------------------- /CopyMultipleSheetsNewWorkbook: -------------------------------------------------------------------------------- 1 | Pulic Sub CopyMultipleSheetsNewWorkbook() 2 | 3 | Dim Wb1 As Workbook 4 | Dim dateStr As String 5 | Dim myDate As Date 6 | Dim Links As Variant 7 | Dim i As Integer 8 | 9 | With Application 10 | .ScreenUpdating = False 11 | .DisplayAlerts = False 12 | .EnableEvents = False 13 | End With 14 | 15 | Set Wb1 = ActiveWorkbook 16 | 17 | myDate = Date 18 | 19 | dateStr = Format(myDate, "MM-DD-YYYY") 20 | 21 | Wb1.Sheets(Array("Sheet1Name", "Sheet2Name", "etc."))Copy 22 | 23 | With ActiveWorkbook 24 | Links = .LinkSources(xlExcelLinks) 25 | If Not IsEmpty(Links) Then 26 | For i = 1 To UBound(Links) 27 | .BreakLink Links(i), xlLinkTypeExcelLinks 28 | Next i 29 | End If 30 | 31 | End With 32 | 33 | ActiveWorkbook.SaveAs Filename:="N:\" & "Report Name" & " " & dateStr, FileFormat:=51 34 | ActiveWorkbook.SaveAs Filename:="N:\Report Archive\" & "Report Name" & " " & dateStr, FileFormat:=51 35 | 36 | ActiveWorkbook.Close 37 | 38 | With Application 39 | .ScreenUpdating = True 40 | .DisplayAlerts = True 41 | .EnableEvents = True 42 | End With 43 | End Sub 44 | -------------------------------------------------------------------------------- /RefreshDataConnection: -------------------------------------------------------------------------------- 1 | Public Sub refreshConnections() 2 | 3 | 'display alerts is stopping credentials challenge to appear. 4 | 'disable display alerts temporarily for data query and enable after 5 | 6 | Application.DisplayAlerts = True 7 | '********************* DATA CONNECTION UPDATES ********************* 8 | ThisWorkbook.Queries.FastCombine = True 'POTENTIAL SECURITY ISSUE 9 | 10 | 'include error handler as sometimes data queries have credential problems. 11 | On Error GoTo refreshErrHandler 12 | ThisWorkbook.Connections("Query - QueryName").Refresh 13 | 'Application.CalculateUntilAsyncQueriesDone 14 | Application.DisplayAlerts = False 15 | 16 | Exit Sub 17 | 18 | refreshErrHandler: 19 | MsgBox "Err message", vbCritical, "Error Issue" 20 | End 21 | 22 | End Sub 23 | 24 | 'if Application.CalculateUntilAsyncQueriesDone causes Excel to freeze and crash, 25 | 'disable "Enable background refresh" option in Connection Properties. 26 | 'Data (Ribbon) > Connections > (Select one connection) Properties > Uncheck "Enable background refresh" 27 | 'or Alt+A+O > (Select one connection) Properties > Uncheck "Enable background refresh" 28 | 'reference: https://www.reddit.com/r/vba/comments/611xqd/applicationcalculateuntilasyncqueriesdone_causes/ 29 | -------------------------------------------------------------------------------- /SendEmailViaVBAMethod3: -------------------------------------------------------------------------------- 1 | Public Sub SendMailO365() 2 | 3 | 'This method sends email via Outlook365 without the need for user's username and password 4 | 'The "From" field accepts any value as long as it contains "@" and ".", recommend maintain with noreply@org.com 5 | 6 | 'Declare Send Mail Property 7 | Dim oConf As Object 8 | Set oConf = CreateObject("CDO.Configuration") 9 | 10 | 'CDO Source Defaults 11 | oConf.Load -1 12 | With oConf.Fields 13 | .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 14 | .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = serverPath 15 | .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = serverPort 16 | .Update 17 | End With 18 | 19 | 'Create email 20 | Dim oMsg As Object 21 | Set oMsg = Nothing 22 | Set oMsg = CreateObject("CDO.Message") 23 | 'Set iConf = CreateObject("CDO.Configuration") 24 | 25 | With oMsg 26 | Set .Configuration = oConf 27 | .To = "" 28 | .CC = "" 29 | '.BCC = "" 30 | .From = "" 31 | .Subject = "" 32 | .BodyPart.Charset = "utf-8" 'to accept chinese characters 33 | .HTMLBody = "" 34 | '.TextBody = "" 35 | '.AddAttachment (fullAttachmentPath) 36 | .Send 37 | End With 38 | 39 | End Sub 40 | -------------------------------------------------------------------------------- /GetFilteredRangeTopBtmRows: -------------------------------------------------------------------------------- 1 | Public Function GetFiltRgTopRow() As Long 2 | 3 | 'this function returns the top row number of a filtered list 4 | 5 | Dim HeaderRow As Long 6 | Dim LastFilterRow As Long 7 | 8 | On Error GoTo NoFilterOnSheet 9 | With ActiveSheet 10 | HeaderRow = .AutoFilter.Range(1).Row 11 | LastFilterRow = .Range(Split(.AutoFilter.Range.Address, ":")(1)).Row 12 | GetFiltRgTopRow = .Range(.Rows(HeaderRow + 1), .Rows(Rows.Count)).SpecialCells(xlCellTypeVisible)(1).Row 13 | If GetFiltRgTopRow = LastFilterRow + 1 Then GetFiltRgTopRow = 0 14 | End With 15 | 16 | NoFilterOnSheet: 17 | 18 | End Function 19 | 20 | Public Function GetFiltRgBtmRow() As Long 21 | 22 | 'this function returns the bottom row number of a filtered list 23 | 24 | Dim HeaderRow As Long 25 | Dim LastFilterRow As Long 26 | Dim Addresses() As String 27 | 28 | On Error GoTo NoFilterOnSheet 29 | With ActiveSheet 30 | HeaderRow = .AutoFilter.Range(1).Row 31 | LastFilterRow = .Range(Split(.AutoFilter.Range.Address, ":")(1)).Row 32 | Addresses = Split(.Range((HeaderRow + 1) & ":" & LastFilterRow).SpecialCells(xlCellTypeVisible).Address, "$") 33 | GetFiltRgBtmRow = Addresses(UBound(Addresses)) 34 | End With 35 | 36 | NoFilterOnSheet: 37 | 38 | End Function 39 | -------------------------------------------------------------------------------- /SearchForHTML: -------------------------------------------------------------------------------- 1 | Public Function HTMLSearchFor(ByRef oPage As Object, ByRef sSearchText As String, Optional iSearchCat As Integer = 1) As Object 2 | 3 | 'this function looks for the HTML document elements needed 4 | 'function allows approximate matching via flipping the iSearchCat switch 5 | '(1 for ID matching, 2 for Tag Name matching) 6 | 7 | Dim dErrTime As Date 8 | 9 | On Error GoTo errHandlerHTMLSearch 10 | dErrTime = Now() 11 | 12 | If iSearchCat = 1 Then 13 | Set HTMLSearchFor = oPage.Document.getElementById(sSearchText) 14 | ElseIf iSearchCat = 2 Then 15 | Set HTMLSearchFor = oPage.Document.getElementsByTagName(sSearchText) 16 | End If 17 | 18 | Exit Function 19 | 20 | errHandlerHTMLSearch: 21 | 'type mismatch error from HTMLSearchFor, looking for data while waiting for page is loading 22 | 'used as a makeshift do while/application wait, end if looped more than a minute 23 | 'Err.Raise (Err.Number) 24 | Err.Number = 0 25 | If Now() >= dErrTime + TimeValue("00:01:00") Then 26 | If sSearchText = "QUICKSEARCH_TABLE" Then 27 | Set HTMLSearchFor = Nothing 28 | Exit Function 29 | Else 30 | MsgBox "Macro stuck in infinite loop. Please retry macro. If problem persists, contact macro creator.", vbExclamation, "ERROR!" 31 | End 32 | End If 33 | End If 34 | Resume 35 | 36 | End Function 37 | -------------------------------------------------------------------------------- /DeleteXSheets: -------------------------------------------------------------------------------- 1 | Public Sub deleteXSheets(ByVal sShName As String, Optional bApprox As Boolean) 2 | 3 | 'deletes sheets based on sheet name 4 | 'allows option for exact name or approximate, 5 | 'bApprox = false (default) for exact string lookup and true for approximate 6 | 7 | Dim sSearchStr As String 8 | 9 | deleteInd = MsgBox("This function requires deletion of all " & sShName & " sheets. Are you sure you want to delete all of the " & sShName & " sheets?", vbYesNo, sShName & " Sheets Deletion") 10 | If deleteInd = vbYes Then 11 | Application.DisplayAlerts = False 12 | 13 | If bApprox = True Then 14 | sSearchStr = "*" & sShName & "*" 15 | Else 16 | sSearchStr = sShName 17 | End If 18 | 19 | 'delete all sheets with the keyword 20 | For i = Sheets.Count To 1 Step -1 21 | If Sheets(i).Name Like sSearchStr Then 22 | ThisWorkbook.Sheets(i).Delete 23 | End If 24 | Next i 25 | 26 | Application.DisplayAlerts = True 27 | 'MsgBox "Done!" 28 | 29 | Else 30 | ThisWorkbook.Sheets("Macro").Activate 31 | MsgBox "User cancelled. To avoid deletion for all of the " & sShName & " sheets you have, rename them to something that does not contain the keyword " & sShName & " and re-run the function. Macro will now terminate." 32 | End 33 | End If 34 | 35 | End Sub 36 | -------------------------------------------------------------------------------- /ColorizeCells: -------------------------------------------------------------------------------- 1 | 'sub colorizes range based on startrow, startcol, endrow, endcol 2 | Public Sub colorizeCells(ByVal lStartRow As Long, ByVal iStartCol As Integer, ByVal lEndRow As Long, ByVal iEndCol As Integer, ByVal iClrSwtch As Integer) 3 | 4 | 'iClrSwtch controls color that goes into range 5 | 6 | If iClrSwtch = 1 Then 7 | 'BLUE 8 | With Range(Cells(lStartRow, iStartCol), Cells(lEndRow, iEndCol)).Interior 9 | .Pattern = xlSolid 10 | .PatternColorIndex = xlAutomatic 11 | .ThemeColor = xlThemeColorAccent1 12 | .TintAndShade = 0.599993896298105 13 | .PatternTintAndShade = 0 14 | End With 15 | ElseIf iClrSwtch = 2 Then 16 | 'GREY 17 | With Range(Cells(lStartRow, iStartCol), Cells(lEndRow, iEndCol)).Interior 18 | .Pattern = xlSolid 19 | .PatternColorIndex = xlAutomatic 20 | .ThemeColor = xlThemeColorDark2 21 | .TintAndShade = 0 22 | .PatternTintAndShade = 0 23 | End With 24 | ElseIf iClrSwtch = 3 Then 25 | 'DARK GREY 26 | With Range(Cells(lStartRow, iStartCol), Cells(lEndRow, iEndCol)).Interior 27 | .Pattern = xlSolid 28 | .PatternColorIndex = xlAutomatic 29 | .ThemeColor = xlThemeColorDark1 30 | .TintAndShade = -0.249977111117893 31 | .PatternTintAndShade = 0 32 | End With 33 | End If 34 | 35 | End Sub 36 | -------------------------------------------------------------------------------- /SQLInsertToDBViaVBA: -------------------------------------------------------------------------------- 1 | Public Function InsertDataToSQLServer(ByVal sSQLInput As String) 2 | 3 | 'Call sample 4 | 'Call InsertDataToSQLServer("INSERT INTO MasterList (Materials, Date, Action) VALUES ('Test7', '" & Format(Now, "mm/dd/yyyy") & "', '');") 5 | 6 | 'connect SQL Server to send emel 7 | Dim dbRecSet As New ADODB.Recordset 'declare recordset for pulling and copying of data from database 8 | Dim dbConnctn As ADODB.Connection 'declare connection to connect to database 9 | Dim dbComnd As ADODB.Command 'declare commands to pull out data 10 | 11 | sServer = a 'Server Name 12 | sDbase = b 'Database Name 13 | sUName = c 'DBAdmin Username 14 | sPWord = d 'DBAdmin Username 15 | 'SQL String Query 16 | sSQLStr = sSQLInput 17 | 18 | 'connect to database with provided credentials 19 | Set dbConnctn = New ADODB.Connection 20 | dbConnctn.Open "Provider=sqloledb;" & _ 21 | "Server=" & sServer & ";Database=" & sDbase & ";" & "User ID=" & sUName & ";Password=" & sPWord & ";" 22 | 23 | 'execute the SQL String 24 | dbRecSet.Open sSQLStr, dbConnctn, adOpenStatic, adLockReadOnly, adCmdText 25 | 26 | 'close database and clear recordsets 27 | If CBool(dbRecSet.State And adStateOpen) = True Then dbRecSet.Close 28 | Set dbRecSet = Nothing 29 | If CBool(dbConnctn.State And adStateOpen) = True Then dbConnctn.Close 30 | Set dbConnctn = Nothing 31 | 32 | End Function 33 | -------------------------------------------------------------------------------- /SQLDisplayDataFromDBViaVBA: -------------------------------------------------------------------------------- 1 | Public Sub DisplayDataFromSQLServer() 2 | 3 | 'connect SQL Server to send emel 4 | Dim dbRecSet As New ADODB.Recordset 'declare recordset for pulling and copying of data from database 5 | Dim dbConnctn As ADODB.Connection 'declare connection to connect to database 6 | Dim dbComnd As ADODB.Command 'declare commands to pull out data 7 | Dim sServer As String 8 | Dim sDbase As String 9 | Dim sUName As String 10 | Dim sPWord As String 11 | Dim sSQLStr As String 12 | Dim parameterSize As Long 13 | 14 | sServer = a 'Server Name 15 | sDbase = b 'Database Name 16 | sUName = c 'DBAdmin Username 17 | sPWord = d 'DBAdmin Username 18 | 'SQL String Query 19 | sSQLStr = "SELECT * FROM MasterList" 20 | 21 | 'connect to database with provided credentials 22 | Set dbConnctn = New ADODB.Connection 23 | dbConnctn.Open "Provider=sqloledb;" & _ 24 | "Server=" & sServer & ";Database=" & sDbase & ";" & "User ID=" & sUName & ";Password=" & sPWord & ";" 25 | 26 | dbRecSet.Open sSQLStr, dbConnctn, adOpenStatic 27 | ' Dump to spreadsheet 28 | With Worksheets("Sheet1").Cells(2, 1) ' Enter your sheet name and range here 29 | .ClearContents 30 | .CopyFromRecordset dbRecSet 31 | End With 32 | 33 | 'close database and clear recordsets 34 | dbRecSet.Close 35 | Set dbRecSet = Nothing 36 | dbConnctn.Close 37 | Set dbConnctn = Nothing 38 | 39 | End Sub 40 | -------------------------------------------------------------------------------- /FindInFolderMoveAndRename: -------------------------------------------------------------------------------- 1 | Public Sub FindInFolderMoveAndRename() 2 | 3 | 'This functions gets into the specified folder, looks for the target file name and moves and renames the file 4 | 'to the desired name and location 5 | 6 | Dim sDirectoryPath As String 7 | Dim fileSys As FileSystemObject 8 | Dim sFolderPath As Variant 9 | Dim objFile As File 10 | Dim strFilename As String 11 | Dim dCompDate As Date 12 | Dim bBOMDownloaded As Boolean 13 | 14 | 'set up filesys objects and set path for files - change for your folder 15 | sDirectoryPath = Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Downloads" 16 | Set fileSys = New FileSystemObject 17 | Set sFolderPath = fileSys.GetFolder(sDirectoryPath) 18 | 19 | 'loop through each file and get date created. If larger than dCompDate then store fname 20 | dCompDate = Date & " 00:00:01" 21 | For Each objFile In sFolderPath.Files 22 | If objFile.Name Like "agile_*" And objFile.DateCreated > dCompDate Then 23 | strFilename = objFile.Name 24 | dCompDate = objFile.DateCreated 25 | End If 26 | Next objFile 27 | 28 | If strFilename <> "" Then 29 | bBOMDownloaded = True 30 | Name sDirectoryPath & "\" & strFilename As ThisWorkbook.Path & "\" & aBOMVals(i) & ".xls" 31 | Else 32 | bBOMDownloaded = False 33 | End If 34 | 35 | Set fileSys = Nothing 36 | Set sFolderPath = Nothing 37 | Set objFile = Nothing 38 | 39 | End Sub 40 | -------------------------------------------------------------------------------- /SAPConnectFromVBA: -------------------------------------------------------------------------------- 1 | Public Sub SAPPull() 2 | 3 | SAPCheck = MsgBox("You must be logged into SAP to run this macro, failure to do so will produce an error with the macro. Are you logged in to SAP?", vbYesNo, "SAP Login Check") 4 | If SAPCheck = vbNo Then 5 | MsgBox "Please log into SAP and try to run the macro again." 6 | End 7 | End If 8 | 9 | 'Connect to SAP 10 | Set SapGuiAuto = GetObject("SAPGUI") 11 | Set applications = SapGuiAuto.GetScriptingEngine 12 | 13 | 'Check existance of SAP logon screen first before proceed 14 | If applications.Children.Count > 0 Then 15 | Set Connection = applications.Children(0) 16 | 17 | 'SAP is available, run checks before proceeding 18 | Call checkAll 19 | 20 | Else 21 | MsgBox "This macro requires access to the SAP system and no SAP Logon detected. Please logon to SAP system and try again!" 22 | End 23 | End If 24 | 25 | Set session = Connection.Children(0) 26 | 27 | If Not IsObject(applications) Then 28 | Set SapGuiAuto = GetObject("SAPGUI") 29 | Set applications = SapGuiAuto.GetScriptingEngine 30 | End If 31 | 32 | If Not IsObject(Connection) Then 33 | Set Connection = applications.Children(0) 34 | End If 35 | 36 | If Not IsObject(session) Then 37 | Set session = Connection.Children(0) 38 | End If 39 | 40 | If IsObject(WScript) Then 41 | WScript.ConnectObject session, "on" 42 | WScript.ConnectObject applications, "on" 43 | End If 44 | 45 | End Sub 46 | -------------------------------------------------------------------------------- /SAPControlGridViewWithFindFunction: -------------------------------------------------------------------------------- 1 | 'Click find in the shell session 2 | session.findById("wnd[1]/tbar[0]/btn[71]").press 3 | 4 | 'look for "P1" keyword and click exact word search 5 | session.findById("wnd[2]/usr/txtGS_SEARCH-VALUE").Text = "P1" 6 | session.findById("wnd[2]/usr/chkGS_SEARCH-EXACT_WORD").Selected = True 7 | 8 | 'click execute 9 | session.findById("wnd[2]/tbar[0]/btn[0]").press 10 | 11 | 'if keyword is found 12 | If Left(session.findById("wnd[0]/sbar").Text, 3) = "Hit" Then 13 | 'close find window 14 | session.findById("wnd[2]/tbar[0]/btn[12]").press 15 | 16 | 'correct cell is already selected and highlighted by system. Double click/click choose 17 | session.findById("wnd[1]/tbar[0]/btn[0]").press 18 | 19 | 'click execute in primary SAP window 20 | session.findById("wnd[0]/tbar[1]/btn[8]").press 21 | 22 | 'if keyword is not found 23 | ElseIf session.findById("wnd[0]/sbar").Text = "No Hit Found" Then 24 | 'close find window 25 | session.findById("wnd[2]/tbar[0]/btn[12]").press 26 | 27 | 'close shell window 28 | session.findById("wnd[1]/tbar[0]/btn[12]").press 29 | 30 | 'go back to home screen 31 | session.findById("wnd[0]/tbar[0]/btn[12]").press 32 | 33 | 'unsuppress alerts 34 | Application.DisplayAlerts = True 35 | 36 | 'Display error to user 37 | MsgBox """P1"" User Group not found in SAP List! Contact Macro creator.", , "ERROR!" 38 | 39 | End 40 | 41 | End If 42 | -------------------------------------------------------------------------------- /ClickIE11SaveButton: -------------------------------------------------------------------------------- 1 | 'This function requires a reference to the UIAutomationClient 2 | 'Tools > References > Check "UIAutomationClient" 3 | 4 | 'library code 5 | #If VBA7 Then 6 | Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 7 | Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _ 8 | (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _ 9 | ByVal lpsz2 As String) As Long 10 | #Else 11 | Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 12 | Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _ 13 | (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _ 14 | ByVal lpsz2 As String) As Long 15 | #End If 16 | 17 | Public Function ClickIE11SaveButton(ByRef ieApp As Object) 18 | 19 | Dim o As IUIAutomation 20 | Dim e As IUIAutomationElement 21 | Dim h As Long 22 | Dim iCnd As IUIAutomationCondition 23 | Dim Button As IUIAutomationElement 24 | Dim InvokePattern As IUIAutomationInvokePattern 25 | 26 | Set o = New CUIAutomation 27 | h = ieApp.hwnd 28 | h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString) 29 | If h = 0 Then Exit Function 30 | 31 | Set e = o.ElementFromHandle(ByVal h) 32 | Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Save") 33 | 34 | Set Button = e.FindFirst(TreeScope_Subtree, iCnd) 35 | Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId) 36 | 37 | InvokePattern.Invoke 38 | 39 | End Function 40 | -------------------------------------------------------------------------------- /TransferModuleAcrossWorkbook: -------------------------------------------------------------------------------- 1 | 'SOURCED FROM https://stackoverflow.com/questions/40956465/vba-to-copy-module-from-one-excel-workbook-to-another-workbook 2 | 'README 3 | 'Just make sure, following things are done before running this macro. 4 | ' 5 | 'List Item 6 | 'VB Editor > Tools > References > (Check) Microsoft Visual Basic for Applications Extensibility 5.3 7 | ' 8 | 'List Item 9 | 'File -> Options -> Trust Center -> Trust Center Setttings -> Macro Settings -> Trust Access to the VBA Project object model. 10 | ' 11 | 'Once you do above, copy & paste below code in Source File 12 | 13 | Sub TransferModuleAcrossWorkbook() 14 | 'Copy this VBA Code in SourceMacroModule, & run this macro in Destination workbook by pressing Alt+F8, the whole module gets copied to destination File. 15 | Dim SourceVBProject As VBIDE.VBProject 16 | Dim DestinationVBProject As VBIDE.VBProject 17 | Dim NewWb As Workbook 18 | 19 | Set SourceVBProject = ThisWorkbook.VBProject 20 | Set NewWb = ActiveWorkbook ' Or whatever workbook object you have for the destination 21 | Set DestinationVBProject = NewWb.VBProject 22 | 23 | Dim SourceModule As VBIDE.CodeModule 24 | Dim DestinationModule As VBIDE.CodeModule 25 | Set SourceModule = SourceVBProject.VBComponents("Module1").CodeModule ' Change "Module1" to the relevant source module 26 | ' Add a new module to the destination project 27 | Set DestinationModule = DestinationVBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule 28 | 29 | With SourceModule 30 | DestinationModule.AddFromString .Lines(1, .CountOfLines) 31 | End With 32 | 33 | End Sub 34 | 35 | -------------------------------------------------------------------------------- /QueryCSVWithSQLinVBA: -------------------------------------------------------------------------------- 1 | Public Sub QueryCSVWithVBA() 2 | 3 | 'Explanations can be found at : https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/scripting-articles/ms974559(v=msdn.10)?redirectedfrom=MSDN 4 | 5 | On Error Resume Next 6 | Const adOpenStatic = 3 7 | Const adLockOptimistic = 3 8 | Const adCmdText = &H1 9 | 10 | Set objConnection = CreateObject("ADODB.Connection") 11 | Set objRecordset = CreateObject("ADODB.Recordset") 12 | 13 | strPathtoTextFile = "C:\Databases\" 14 | 15 | 16 | 'For some reason Jet isn't compitable across ALL devices. Will have to switch to ACE 12.0 17 | 'objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _ 18 | ' "Data Source=" & strPathtoTextFile & ";" & _ 19 | ' "Extended Properties=""text;HDR=YES;FMT=FixedLength""" 20 | 21 | objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 22 | "Data Source=" & strPathtoTextFile & ";" & _ 23 | "Extended Properties=""text;HDR=YES;FMT=FixedLength""" 24 | 25 | objRecordset.Open "SELECT * FROM PhoneList.txt", _ 26 | objConnection, adOpenStatic, adLockOptimistic, adCmdText 27 | 28 | Do Until objRecordset.EOF 29 | Wscript.Echo "Name: " & objRecordset.Fields.Item("FirstName") 30 | Wscript.Echo "Department: " & objRecordset.Fields.Item("LastName") 31 | Wscript.Echo "Extension: " & objRecordset.Fields.Item("ID") 32 | objRecordset.MoveNext 33 | Loop 34 | 35 | 'close database and clear recordsets 36 | objRecordset.Close 37 | Set objRecordset = Nothing 38 | objConnection.Close 39 | Set objConnection = Nothing 40 | 41 | End Sub 42 | -------------------------------------------------------------------------------- /StringIncrementer: -------------------------------------------------------------------------------- 1 | Public Sub StringIncrementer() 2 | 3 | 'This function accepts string inputs into "oriString" variable whereby the string input is in actuality 4 | 'a shorthand for a range of incrementing serials of mixed alphabet and integer composition. 5 | 'The sub splits the alphabets from the integers, gets the last values of the final integer series and tags them 6 | 'as start and end. It then recombines the beginning fillers of the serial and increments the final integer values 7 | 'into the longhand form. 8 | 'e.g: "A1B1 - A1B5" is transformed to "A1B1, A1B2, A1B3, A1B4, A1B5" 9 | 10 | Dim oriString As String 11 | Dim modString As String 12 | Dim splitString() As String 13 | Dim splitStart() As String 14 | Dim splitEnd() As String 15 | Dim sStart As String 16 | Dim sEnd As String 17 | Dim lStart As Long 18 | Dim lEnd As Long 19 | Dim sFill As String 20 | Dim sFinal As String 21 | 22 | oriString = "A1B9 - A1B11" 23 | modString = Replace(oriString, " ", "") 24 | splitString = Split(modString, "-") 25 | sStart = splitString(0) 26 | sEnd = splitString(1) 27 | 28 | With CreateObject("VBScript.RegExp") 29 | .Pattern = "(\d+|\D+)" 30 | .Global = True 31 | splitStart = Split(Mid(.Replace(sStart, "|$1"), 2), "|") 32 | splitEnd = Split(Mid(.Replace(sEnd, "|$1"), 2), "|") 33 | sFill = splitStart(0) & splitStart(1) & splitStart(2) 34 | lStart = splitStart(3) 35 | lEnd = splitEnd(3) 36 | End With 37 | 38 | For i = lStart To lEnd 39 | If sFinal = "" Then 40 | sFinal = sFill & i 41 | Else 42 | sFinal = sFinal & ", " & sFill & i 43 | End If 44 | Next i 45 | 46 | End Sub 47 | -------------------------------------------------------------------------------- /PivotTableSample1: -------------------------------------------------------------------------------- 1 | Public Sub PivotTableSample1() 2 | Dim objTable As PivotTable 3 | Dim objField As PivotField 4 | 5 | 'Pivot table creation algo 6 | Sheets("PGI").Range(Cells(lngFirstRow, intFirstCol), Cells(lngLastRow, intLastCol)).Select 7 | 8 | ' Create the PivotTable object based on the Employee data on Sheet1. 9 | Set objTable = Sheets("PGI").PivotTableWizard 10 | 11 | pivotName = ActiveSheet.PivotTables(1).Name 12 | 13 | With ActiveSheet.PivotTables(pivotName) 14 | 15 | With .PivotFields("MRP Controller") 16 | .Orientation = xlRowField 17 | .Position = 1 18 | End With 19 | 20 | With .PivotFields("Material") 21 | .Orientation = xlRowField 22 | .Position = 2 23 | End With 24 | 25 | With .PivotFields("DELIVERYQTY") 26 | .Orientation = xlRowField 27 | .Position = 3 28 | End With 29 | 30 | With .PivotFields("Act. Gds Mvmnt Date") 31 | .Orientation = xlRowField 32 | .Position = 4 33 | End With 34 | 35 | .PivotFields("MRP Controller").LayoutForm = xlTabular 36 | .PivotFields("Material").LayoutForm = xlTabular 37 | .PivotFields("DELIVERYQTY").LayoutForm = xlTabular 38 | .PivotFields("Act. Gds Mvmnt Date").LayoutForm = xlTabular 39 | 40 | .AddDataField ActiveSheet.PivotTables(pivotName).PivotFields("DELIVERYQTY"), "Sum of Qty", xlSum 41 | 42 | End With 43 | 44 | ActiveSheet.Name = "PGI PivotTable" 45 | ActiveSheet.Cells.EntireColumn.AutoFit 46 | ActiveSheet.Cells.EntireRow.AutoFit 47 | 48 | With Cells 49 | .Copy 50 | .PasteSpecial xlPasteValues 51 | End With 52 | 53 | Application.CutCopyMode = False 54 | -------------------------------------------------------------------------------- /GetLineNumLargeFile: -------------------------------------------------------------------------------- 1 | 'source : https://stackoverflow.com/questions/13598691/read-number-of-lines-in-large-text-file-vb6 2 | 3 | Option Explicit 4 | 5 | Private Sub Main() 6 | Const BUFSIZE As Long = 100000 7 | Dim T0 As Single 8 | Dim LfAnsi As String 9 | Dim F As Integer 10 | Dim FileBytes As Long 11 | Dim BytesLeft As Long 12 | Dim Buffer() As Byte 13 | Dim strBuffer As String 14 | Dim BufPos As Long 15 | Dim LineCount As Long 16 | 17 | T0 = Timer() 18 | LfAnsi = StrConv(vbLf, vbFromUnicode) 19 | F = FreeFile(0) 20 | Open "big.txt" For Binary Access Read As #F 21 | FileBytes = LOF(F) 22 | ReDim Buffer(BUFSIZE - 1) 23 | BytesLeft = FileBytes 24 | Do Until BytesLeft = 0 25 | If BufPos = 0 Then 26 | If BytesLeft < BUFSIZE Then ReDim Buffer(BytesLeft - 1) 27 | Get #F, , Buffer 28 | strBuffer = Buffer 'Binary copy of bytes. 29 | BytesLeft = BytesLeft - LenB(strBuffer) 30 | BufPos = 1 31 | End If 32 | Do Until BufPos = 0 33 | BufPos = InStrB(BufPos, strBuffer, LfAnsi) 34 | If BufPos > 0 Then 35 | LineCount = LineCount + 1 36 | BufPos = BufPos + 1 37 | End If 38 | Loop 39 | Loop 40 | Close #F 41 | 'Add 1 to LineCount if last line of your files do not 42 | 'have a trailing CrLf. 43 | MsgBox "Counted " & Format$(LineCount, "#,##0") & " lines in" & vbNewLine _ 44 | & Format$(FileBytes, "#,##0") & " bytes of text." & vbNewLine _ 45 | & Format$(Timer() - T0, "0.0#") & " seconds." 46 | End Sub 47 | -------------------------------------------------------------------------------- /ConvertRangetoHTML: -------------------------------------------------------------------------------- 1 | Public Function RangetoHTML(rng As Range) 2 | 3 | 'Original code By Ron de Bruin. 4 | 5 | Dim fso As Object 6 | Dim ts As Object 7 | Dim TempFile As String 8 | Dim TempWB As Workbook 9 | 10 | TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 11 | 12 | 'Copy the range and create a new workbook to past the data in 13 | rng.Copy 14 | Set TempWB = Workbooks.Add(1) 15 | With TempWB.Sheets(1) 16 | .Cells(1).PasteSpecial Paste:=8 17 | .Cells(1).PasteSpecial xlPasteValues, , False, False 18 | .Cells(1).PasteSpecial xlPasteFormats, , False, False 19 | .Cells(1).Select 20 | Application.CutCopyMode = False 21 | On Error Resume Next 22 | .DrawingObjects.Visible = True 23 | .DrawingObjects.Delete 24 | On Error GoTo 0 25 | End With 26 | 27 | 'Publish the sheet to a htm file 28 | With TempWB.PublishObjects.Add( _ 29 | SourceType:=xlSourceRange, _ 30 | Filename:=TempFile, _ 31 | Sheet:=TempWB.Sheets(1).Name, _ 32 | Source:=TempWB.Sheets(1).UsedRange.Address, _ 33 | HtmlType:=xlHtmlStatic) 34 | .Publish (True) 35 | End With 36 | 37 | 'Read all data from the htm file into RangetoHTML 38 | Set fso = CreateObject("Scripting.FileSystemObject") 39 | Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) 40 | RangetoHTML = ts.ReadAll 41 | ts.Close 42 | RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ 43 | "align=left x:publishsource=") 44 | 45 | 'Close TempWB 46 | TempWB.Close savechanges:=False 47 | 48 | 'Delete the htm file we used in this function 49 | Kill TempFile 50 | 51 | Set ts = Nothing 52 | Set fso = Nothing 53 | Set TempWB = Nothing 54 | 55 | End Function 56 | -------------------------------------------------------------------------------- /ExtractNumber: -------------------------------------------------------------------------------- 1 | Public Function ExtractNumber(rCell As Range, Optional Take_decimal As Boolean, Optional Take_negative As Boolean) As Double 2 | 3 | 'this function extracts any integer value within a string of text 4 | 5 | Dim iCount As Integer, i As Integer, iLoop As Integer 6 | Dim sText As String, strNeg As String, strDec As String 7 | Dim lNum As String 8 | Dim vVal, vVal2 9 | 10 | sText = rCell 11 | 12 | If Take_decimal = True And Take_negative = True Then 13 | strNeg = "-" 'Negative Sign MUST be before 1st number. 14 | strDec = "." 15 | ElseIf Take_decimal = True And Take_negative = False Then 16 | strNeg = vbNullString 17 | strDec = "." 18 | ElseIf Take_decimal = False And Take_negative = True Then 19 | strNeg = "-" 20 | strDec = vbNullString 21 | End If 22 | 23 | iLoop = Len(sText) 24 | 25 | For iCount = iLoop To 1 Step -1 26 | 27 | vVal = Mid(sText, iCount, 1) 28 | 29 | If IsNumeric(vVal) Or vVal = strNeg Or vVal = strDec Then 30 | i = i + 1 31 | lNum = Mid(sText, iCount, 1) & lNum 32 | 33 | If IsNumeric(lNum) Then 34 | If CDbl(lNum) < 0 Then 35 | Exit For 36 | End If 37 | Else 38 | lNum = Replace(lNum, Left(lNum, 1), "", , 1) 39 | End If 40 | 41 | End If 42 | 43 | If i = 1 And lNum <> vbNullString Then 44 | lNum = CDbl(Mid(lNum, 1, 1)) 45 | End If 46 | 47 | Next iCount 48 | 49 | ExtractNumber = CDbl(lNum) 50 | 51 | End Function 52 | -------------------------------------------------------------------------------- /SQLRunStoredProcedureViaVBA: -------------------------------------------------------------------------------- 1 | Public Sub RunStoredProc() 2 | 3 | 'This Sub requires reference to the Microsoft ActiveX Data Objects (ADODB) Library. Get the one with the biggest Version number and you should be okay. 4 | HtmlContent = "Hello," + vbLf + "Below are the Material number that need a fair report." + vbLf + sArgs + vbLf + "Thanks and Regards." 5 | 6 | 'connect SQL Server to send email 7 | Dim dbRecSet As New ADODB.Recordset 'declare recordset for pulling and copying of data from database 8 | Dim dbConnctn As ADODB.Connection 'declare connection to connect to database 9 | Dim dbComnd As ADODB.Command 'declare commands to pull out data 10 | Dim sServer As String 11 | Dim sDbase As String 12 | Dim sUName As String 13 | Dim sPWord As String 14 | Dim parameterSize As Long 15 | 16 | sServer = a 'Server Name 17 | sDbase = b 'Database Name 18 | sUName = c 'DBAdmin Username 19 | sPWord = d 'DBAdmin Password 20 | 21 | 'connect to database with provided credentials 22 | Set dbConnctn = New ADODB.Connection 23 | dbConnctn.Open "Provider=sqloledb;" & _ 24 | "Server=" & sServer & ";Database=" & sDbase & ";" & "User ID=" & sUName & ";Password=" & sPWord & ";" 25 | 26 | 'create a new command and input settings 27 | Set dbComnd = New ADODB.Command 28 | 29 | 'to Run Stored Procedure 30 | With dbComnd 31 | .ActiveConnection = dbConnctn 'use preexisting connection 32 | .CommandText = "sp_sendEmail" 'Stored procedure name 33 | .CommandType = adCmdStoredProc 'default 34 | .CommandTimeout = 3000 'timeout value in seconds 35 | 'parameter adding *repeat as many times as you have parameters 36 | '.Parameters.Append .CreateParameter("your parameter name", adInteger, adParamInput, paramLength, your parameter value) 37 | .Parameters.Append .CreateParameter("@MaterialNumber", adLongVarWChar, adParamInput, adArray, HtmlContent) 38 | 'use recordset to latch on to the data retreived (most important bit) 39 | Set dbRecSet = .Execute 40 | End With 41 | 42 | 'close database 43 | dbConnctn.Close 44 | 45 | End Sub 46 | -------------------------------------------------------------------------------- /CheckAll: -------------------------------------------------------------------------------- 1 | Public Sub checkAll() 2 | 3 | 'This sub checks all of the necessary fields in the macro sheet to make sure all of the fields are filled. 4 | 5 | Dim dUsedDate As Date 6 | 7 | 'Checks SAP access 8 | SAPCheck = MsgBox("You must be logged into SAP to run this macro, failure to do so will produce an error with the macro. Are you logged in to SAP?", vbYesNo, "SAP Login Check") 9 | If SAPCheck = vbNo Then 10 | MsgBox "Please log into SAP and try to run the macro again." 11 | End 12 | End If 13 | 14 | Dim aWbLoc(0 To 1) As String 15 | aWbLoc(0) = "C4" 16 | aWbLoc(1) = "C8" 17 | 18 | Dim aWbVars(0 To 1) As String 19 | aWbVars(0) = "X" 20 | aWbVars(1) = "X" 21 | 22 | dUsedDate = Format(Date, "mm/dd/yyyy") 23 | 24 | 'catches empty workbook and sheet 25 | For i = 0 To 1 26 | 27 | If ThisWorkbook.Sheets("Macro").Range(aWbLoc(i)).Value = "" Then 28 | MsgBox "Please select the " & aWbVars(i) & " Workbook first by clicking the " & aWbVars(i) & """ Browse"" Button before running the macro!" 29 | End 30 | End If 31 | 32 | If ThisWorkbook.Sheets("Macro").OLEObjects("ComboBox" & i + 1).Object.Value = "" Then 33 | MsgBox "Please select the Worksheet for " & aWbVars(i) & " Workbook first before running the macro!" 34 | End 35 | End If 36 | 37 | Next i 38 | 39 | 'check if macro location contains workbook name. if not, create new one. else delete the old one, run the current. 40 | sFName = "X" & Format(dUsedDate, "mmddyyyy") 41 | sCheck = Dir(ThisWorkbook.Path & "\" & sFName & "*") 42 | 43 | 'check if previous run is in folder or not 44 | 'if found, confirm delete with user 45 | If sCheck <> "" Then 46 | deletePrevFle = MsgBox("The macro has been run for the day and a previous version is detected. Do you want to delete the previous version and override with this run?", vbYesNo, "Previous workbook delete confirmation") 47 | If deletePrevFle = vbYes Then 48 | Kill ThisWorkbook.Path & "\" & sCheck 49 | Else 50 | ThisWorkbook.Sheets("Macro").Activate 51 | MsgBox "Previous workbook deletion cancelled. Macro terminated." 52 | End 53 | End If 54 | End If 55 | 56 | Call main 57 | 58 | End Sub 59 | -------------------------------------------------------------------------------- /MakeTableBorder: -------------------------------------------------------------------------------- 1 | Public Sub MakeTableBorder(ByVal iStartRow As Integer, ByVal iStartCol As Integer, ByVal iEndRow As Integer, ByVal iEndCol As Integer, Optional ByVal bThickSwitch As Boolean = False) 2 | 3 | 'function creates an all encompassing table line around the data with user provided: 4 | 'Start Row, Start Column, End Row and End Column, Thick Switch 5 | 6 | With Range(Cells(iStartRow, iStartCol), Cells(iEndRow, iEndCol)) 7 | .Borders(xlDiagonalDown).LineStyle = xlNone 8 | .Borders(xlDiagonalUp).LineStyle = xlNone 9 | 10 | With .Borders(xlEdgeLeft) 11 | .LineStyle = xlContinuous 12 | .ColorIndex = 0 13 | .TintAndShade = 0 14 | If bThickSwitch = True Then .Weight = xlMedium Else .Weight = xlThin 15 | End With 16 | 17 | With .Borders(xlEdgeTop) 18 | .LineStyle = xlContinuous 19 | .ColorIndex = 0 20 | .TintAndShade = 0 21 | If bThickSwitch = True Then .Weight = xlMedium Else .Weight = xlThin 22 | End With 23 | 24 | With .Borders(xlEdgeBottom) 25 | .LineStyle = xlContinuous 26 | .ColorIndex = 0 27 | .TintAndShade = 0 28 | If bThickSwitch = True Then .Weight = xlMedium Else .Weight = xlThin 29 | End With 30 | 31 | With .Borders(xlEdgeRight) 32 | .LineStyle = xlContinuous 33 | .ColorIndex = 0 34 | .TintAndShade = 0 35 | If bThickSwitch = True Then .Weight = xlMedium Else .Weight = xlThin 36 | End With 37 | 38 | With .Borders(xlInsideVertical) 39 | .LineStyle = xlContinuous 40 | .ColorIndex = 0 41 | .TintAndShade = 0 42 | If bThickSwitch = True Then .Weight = xlMedium Else .Weight = xlThin 43 | End With 44 | 45 | With .Borders(xlInsideHorizontal) 46 | .LineStyle = xlContinuous 47 | .ColorIndex = 0 48 | .TintAndShade = 0 49 | If bThickSwitch = True Then .Weight = xlMedium Else .Weight = xlThin 50 | End With 51 | 52 | If bThickSwitch = True Then 53 | .Borders(xlInsideVertical).LineStyle = xlNone 54 | .Borders(xlInsideHorizontal).LineStyle = xlNone 55 | End If 56 | End With 57 | 58 | End Sub 59 | -------------------------------------------------------------------------------- /PivotTableSample2: -------------------------------------------------------------------------------- 1 | 'Pivot table 2 | sPtName = "PivotTable1" 3 | sShName = "Temp" 4 | sTargShName = ActiveSheet.Name 5 | 6 | 'get last cell address, check if the header is empty 7 | colToCheck = Range(lastCellAdd).Column 8 | checkHeaderVal: 9 | If Cells(1, colToCheck).Value = "" Then 10 | colToCheck = colToCheck - 1 11 | GoTo checkHeaderVal 12 | End If 13 | 14 | dtaSource = sTargShName & "!R1C1:R" & Range(lastCellAdd).Row & "C" & colToCheck 15 | 16 | 'add new worksheet to pivot the table (make sure always after CommitAvailabilityDates) 17 | Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = sShName 18 | 19 | ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ 20 | dtaSource, Version:=xlPivotTableVersion12). _ 21 | CreatePivotTable TableDestination:=sShName & "!R3C1", TableName:=sPtName _ 22 | , DefaultVersion:=xlPivotTableVersion12 23 | Sheets(sShName).Select 24 | Cells(3, 1).Select 25 | 26 | 'With ActiveSheet.PivotTables(sPtName).PivotFields("Part Name") 27 | With ActiveSheet.PivotTables(sPtName).PivotFields("Models") 28 | .Orientation = xlRowField 29 | .Position = 1 30 | End With 31 | 32 | With ActiveSheet.PivotTables(sPtName).PivotFields("Order ID") 33 | .Orientation = xlRowField 34 | .Position = 2 35 | End With 36 | 37 | With ActiveSheet.PivotTables(sPtName).PivotFields("CommitWW") 38 | .Orientation = xlColumnField 39 | .Position = 1 40 | End With 41 | 42 | ActiveSheet.PivotTables(sPtName).AddDataField ActiveSheet.PivotTables( _ 43 | sPtName).PivotFields("Allocated Qty"), "Sum of Allocated Qty", xlSum 44 | 45 | With ActiveSheet.PivotTables(sPtName) 46 | .InGridDropZones = True 47 | .RowAxisLayout xlTabularRow 48 | End With 49 | 50 | 'paste as values 51 | Cells.Copy 52 | Range("A1").PasteSpecial Paste:=xlPasteValues 53 | Application.CutCopyMode = False 54 | 55 | 'Delete first three rows 56 | Rows("1:3").EntireRow.Delete 57 | 58 | 'for blank A column fields, copy the cell above 59 | Range(Cells(1, 1), Cells(Range(lastCellAdd).Row, 1)).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" 60 | 61 | 'paste as values 62 | Cells.Copy 63 | Range("A1").PasteSpecial Paste:=xlPasteValues 64 | Application.CutCopyMode = False 65 | -------------------------------------------------------------------------------- /UsefulSheetCodes: -------------------------------------------------------------------------------- 1 | 'Useful algorthms for locked sheet, to allow sorting, filtering, grouping etc 2 | 3 | '*** UNPROTECT SHEET AND CHECK FOR ALLOWED EDIT RANGES *** 4 | Sheets("Main").Unprotect "password" 5 | 6 | 'check if the sheet has edit ranges (to allow sorting through cell lock) 7 | If Sheets("Main").Protection.AllowEditRanges.Count <> 0 Then 8 | For i = 1 To Sheets("Main").Protection.AllowEditRanges.Count 9 | ActiveSheet.Protection.AllowEditRanges(i).Delete 10 | Next i 11 | End If 12 | '********************************************************* 13 | 14 | '*** LOCK SHEET, ALLOW SORTING AND GROUPING, BUT DISALLOW LOCKED CELLS SELECTION *** 15 | 'add allowed edit range to allow users to sort sheet 16 | Sheets("Main").Protection.AllowEditRanges.Add Title:="AllowSort", Range:=Range(Cells(lDataRow_Main + 1, 1), Cells(lLRow_Main, lLCol_Main)) 17 | 'reference : https://stackoverflow.com/questions/10197772/how-to-lock-specific-cells-but-allow-filtering-and-sorting/15390698#15390698 18 | 'NOTE: Solution above may be sufficient, but users can still technically mess up locked ranges if they select an unlocked range and locked range together 19 | (to simulate - Select unlocked cell, drag into locked cell range and delete selection. Deletion will occur). To circumvent this issue, can look reference 2. 20 | 'reference 2 : https://stackoverflow.com/questions/10197772/how-to-lock-specific-cells-but-allow-filtering-and-sorting/50496626#50496626 21 | 22 | 'password protect the sheet 23 | Sheets("Main").Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowSorting:=True, AllowFiltering:=True, UserInterfaceOnly:=True, _ 24 | AllowFormattingColumns:=True, AllowFormattingRows:=True 25 | 26 | 'enable grouping 27 | Sheets("Main").EnableOutlining = True 28 | 29 | 'disable selecting locked cells 30 | Sheets("Main").EnableSelection = xlUnlockedCells 31 | ************************************************************************************ 32 | 33 | 34 | 'To remove grouping, 35 | Range(Cells(lHeadRow_Main, 1), Cells(Range(lastCellAdd).Row, Range(lastCellAdd).Column)).ClearOutline 36 | 37 | 'To reset cell widths and height 38 | Cells.UseStandardHeight = True 39 | Cells.UseStandardWidth = True 40 | -------------------------------------------------------------------------------- /ArrayInitializedCheck: -------------------------------------------------------------------------------- 1 | 'reference for this whole thing can be found at: 2 | '- Short Code sample: https://riptutorial.com/excel-vba/example/30824/check-if-array-is-initialized--if-it-contains-elements-or-not-- 3 | '- Longer explanation 1: https://stackoverflow.com/a/14382846 4 | '- Longer explanation 2: https://www.vbforums.com/showthread.php?654880-How-do-I-tell-if-an-array-is-quot-empty-quot&p=4040234&viewfull=1#post4040234 5 | 6 | '--- Example 1: --- 7 | 'asTestEmpty is considered an empty array. Depending on the datatype, its emptiness can be checked either simply by writing some simple conditions and checks or 8 | 'more complex by looping through the indexes and checking the values one at a time. If its a string, can also join to see what the final string is regardless of 9 | 'array size. 10 | Dim asTestEmpty() As String 11 | ReDim asTestEmpty(0 To 0) As String 12 | 13 | '********************************************************************************************************************************************************************* 14 | 15 | '--- Example 2: --- 16 | 'asTestUninitialized however, is considered uninitialized. This array cannot be looped through and no conditions will work on it as it has no values to apply the 17 | 'conditions to. Best case is by using a triple Not if condition 18 | Dim asTestUninitialized() As String 19 | 20 | '--- Solution 1: --- 21 | If Not Not asTestUninitialized Then MsgBox UBound(asTestUninitialized) Else MsgBox "asTestUninitialized not initialised" 22 | 23 | '--- Solution 2: --- 24 | 'basically same as Solution 1, just with a clearer <>0 condition 25 | If (Not Not asTestUninitialized) <> 0 Then 26 | ' Array has been initialized, so you're good to go. 27 | Else 28 | ' Array has NOT been initialized 29 | End If 30 | 31 | '--- Solution 3: --- 32 | 'basically same as Solution 1, but with one less Not and a condition change to = -1 and initialize/not initialize priority 33 | If (Not asTestUninitialized) = -1 Then 34 | ' Array has NOT been initialized 35 | Else 36 | ' Array has been initialized, so you're good to go. 37 | End If 38 | 39 | 'In VB, for whatever reason, Not myArray returns the SafeArray pointer. For uninitialized arrays, this returns -1. You can Not this to XOR it with -1, thus returning zero, if you prefer. 40 | 41 | ' (Not myArray) (Not Not myArray) 42 | 'Uninitialized -1 0 43 | 'Initialized -someBigNumber someOtherBigNumber 44 | -------------------------------------------------------------------------------- /RangeSelector: -------------------------------------------------------------------------------- 1 | Public Function rangeSelector(ByVal sKeyword As String, wbTarg As Workbook, Optional bMultiCol As Boolean) As String 2 | 3 | 'this function allows users to select a column range and checks it for suitability based on its parameters 4 | 'accepts compulsory keyword value to indicate column to select 5 | 'accepts compulsory workbook value if value is from external workbook that needs closing after selection 6 | 'accepts optional multicolumn switch to allow single column or multiple columns selection (false - default for single column only selection, true for multiple column selection) 7 | 8 | 'ask user to select column to take as material 9 | 'insert input box for acquisition of range 10 | rangeSelect: 11 | Set copyRange = Nothing 12 | 13 | 'on error to suppress errors from clicking cancel 14 | On Error Resume Next 15 | Set copyRange = Application.InputBox("Please select the " & sKeyword & " column(s) manually.", sKeyword & " Column(s) selection", , , , , , 8) 16 | On Error GoTo 0 17 | 18 | 'target workbook needed, otherwise will switch workbooks, Excel2016 bug 19 | wbTarg.Activate 20 | 21 | If copyRange Is Nothing Then 22 | cancelSelect = MsgBox("You clicked cancel during the range selection. Are you sure you want to cancel the macro? This will end the macro and return you to the macro workbook. If you clicked Cancel by mistake, click ""No"" to select the Material range again. Click ""Yes"" to cancel and end.", vbYesNo, sKeyword & " Column Cancellation Confirmation") 23 | If cancelSelect = vbNo Then 24 | GoTo rangeSelect 25 | Else 26 | If Not wbTarg Is Nothing Then 27 | wbTarg.Close savechanges:=False 28 | End If 29 | 30 | ThisWorkbook.Sheets("Macro").Activate 31 | MsgBox "User cancelled. Please re-run the macro to reselect the ranges." 32 | End 33 | End If 34 | 35 | 'user selected more than 1 columns 36 | ElseIf copyRange.Columns.Count <> 1 And bMultiCol <> True Then 37 | MsgBox "You have selected more than 1 column for the " & sKeyword & " Column. Please select ONLY ONE COLUMN." 38 | GoTo rangeSelect 39 | 40 | 'user selected column, but still need to confirm 41 | Else 42 | confirmSelect = MsgBox("You have selected the column """ & copyRange.Address & """ as the " & sKeyword & " Column. Is this correct?", vbYesNo, sKeyword & " Column Confirmation") 43 | If confirmSelect = vbNo Then 44 | GoTo rangeSelect 45 | Else 46 | rangeSelector = copyRange.Address 47 | End If 48 | End If 49 | 50 | End Function 51 | -------------------------------------------------------------------------------- /FindKeyStringInAllFilesInFolder: -------------------------------------------------------------------------------- 1 | Public Sub FindKeyStringInAllFilesInFolder() 2 | 3 | 'This sub will look at all files in a folder for the existence of a key string and list out all the locations where the string appears 4 | 'Created for TEXT lookups: txt, VG2 files, etc. 5 | 'Accepts String for Target Path and Target String to look for in all files 6 | 'This sub will need the FindAllFilesInFolder function to work! 7 | 8 | Application.ScreenUpdating = False 9 | 10 | Dim sAllFilesInFolderName() As String 11 | Dim sTargPath As String 12 | Dim sFilePath As String 13 | Dim sTargetStr As String 14 | Dim sAllReadText As String 15 | Dim arrTextByLine() As String 16 | 17 | Dim i, j As Long 18 | Dim lLastRow As Long 19 | 20 | 'Clear file from previous run 21 | lLastRow = Cells(Rows.Count, 1).End(xlUp).Row 22 | Range(Cells(2, 1), Cells(lLastRow, 3)).Clear 23 | 24 | 'get the names of all of the files in the target folder 25 | sTargPath = Range("B5").Value 'can replace range with address directly here 26 | sAllFilesInFolderName = FindAllFilesInFolder(sTargPath) 27 | sTargetStr = Range("B6").Value 'can replace range with key word directly here 28 | 29 | 'i loops through the file names found in directory 30 | For i = LBound(sAllFilesInFolderName) To UBound(sAllFilesInFolderName) - 1 31 | 32 | sFilePath = sTargPath & "\" & sAllFilesInFolderName(i) 33 | 34 | 'open filepath, read text, close path 35 | Open sFilePath For Binary As #1 36 | sAllReadText = Space$(LOF(1)) 37 | Get #1, , sAllReadText 38 | Close #1 39 | 40 | 'transfer string chunk to array, split by new line 41 | arrTextByLine() = Split(sAllReadText, vbCrLf) 42 | '~~> Now arrTextByLine has all the data from the text file 43 | 'vbCrLf splits at new line (similar to Enter) 44 | 'https://stackoverflow.com/questions/27223228/differences-between-vblf-vbcrlf-vbcr-constants 45 | 46 | 'j loops through all the lines of the data 47 | For j = LBound(arrTextByLine) To UBound(arrTextByLine) 48 | If InStr(1, arrTextByLine(j), sTargetStr, 1) <> 0 Then 49 | lLastRow = Cells(Rows.Count, 1).End(xlUp).Row 50 | Cells(lLastRow + 1, 1).Value = j 51 | Cells(lLastRow + 1, 2).Value = sAllFilesInFolderName(i) 52 | Cells(lLastRow + 1, 3).Value = arrTextByLine(j) 53 | End If 54 | Application.StatusBar = "Ln:" & j & "/" & UBound(arrTextByLine) & " File:" & i & "/" & UBound(sAllFilesInFolderName) - 1 & " " & sAllFilesInFolderName(i) 55 | DoEvents 56 | Next j 57 | Next i 58 | 59 | Application.ScreenUpdating = True 60 | 61 | MsgBox "Done!" 62 | 63 | End Sub 64 | -------------------------------------------------------------------------------- /ConvertExcelRangeToImageViaVBA: -------------------------------------------------------------------------------- 1 | 'CONVERTING EXCEL RANGE TO IMAGE 2 | 3 | 'Const saveSceenshotTo As String = "C:\Users\yourUserName\Desktop\" ' change path to where you want to save 4 | 'Const saveScreenshotTo As String = "C:\Users\ChekassF\Downloads\Macros\Macro Project 3 - Inventory Control (Warehouse, Azmir Khan)\Prototypes" 5 | Const pictureFormat As String = ".jpg" ' change file extension 6 | 7 | Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long 8 | Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long 9 | Private Declare Function CloseClipboard Lib "user32" () As Long 10 | Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long 11 | 12 | Private Type GUID 13 | Data1 As Long 14 | Data2 As Integer 15 | Data3 As Integer 16 | Data4(0 To 7) As Byte 17 | End Type 18 | 19 | Private Type uPicDesc 20 | Size As Long 21 | Type As Long 22 | hPic As Long 23 | hPal As Long 24 | End Type 25 | 26 | Private Const CF_BITMAP = 2 27 | Private Const PICTYPE_BITMAP = 1 28 | 29 | ' run this sub to export pictures 30 | Public Function ExportPicturesToFiles(ByVal wbPath As String) As String 31 | 'Public Sub ExportPicturesToFiles(ByVal wbPath As String) 32 | Dim saveScreenshotTo As String 33 | 34 | saveScreenshotTo = wbPath & pictureFormat 35 | 36 | Dim i As Long 37 | i = 1 38 | Dim pic As Shape 39 | For Each pic In ActiveSheet.Shapes 40 | pic.Copy 41 | MyPrintScreen (saveScreenshotTo) 42 | Next 43 | 44 | ExportPicturesToFiles = saveScreenshotTo 45 | 46 | End Function 47 | 48 | Public Sub MyPrintScreen(FilePathName As String) 49 | 50 | Dim IID_IDispatch As GUID 51 | Dim uPicInfo As uPicDesc 52 | Dim IPic As IPicture 53 | Dim hPtr As Long 54 | 55 | OpenClipboard 0 56 | hPtr = GetClipboardData(CF_BITMAP) 57 | CloseClipboard 58 | 59 | With IID_IDispatch 60 | .Data1 = &H7BF80980 61 | .Data2 = &HBF32 62 | .Data3 = &H101A 63 | .Data4(0) = &H8B 64 | .Data4(1) = &HBB 65 | .Data4(2) = &H0 66 | .Data4(3) = &HAA 67 | .Data4(4) = &H0 68 | .Data4(5) = &H30 69 | .Data4(6) = &HC 70 | .Data4(7) = &HAB 71 | End With 72 | 73 | With uPicInfo 74 | .Size = Len(uPicInfo) 75 | .Type = PICTYPE_BITMAP 76 | .hPic = hPtr 77 | .hPal = 0 78 | End With 79 | 80 | OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic 81 | SavePicture IPic, FilePathName 82 | End Sub 83 | 84 | -------------------------------------------------------------------------------- /UpdateOrClear: -------------------------------------------------------------------------------- 1 | Public Sub UpdateOrClear(ByVal shLanding As String, Optional ByRef wbTarg As Workbook, Optional ByVal shTarg As String, Optional ByVal bCloseResetWB As Boolean = True, Optional ByVal bOnlyClear As Boolean = True) 2 | 3 | 'function to update (copy and paste values from other workbooks to current workbook) or clear 4 | 'shLanding variable accepts current (landing) workbook sheet value 5 | 'wbTarg variable accepts Target workbook value 6 | 'shTarg variable accepts Target workbook sheet value 7 | 'bCloseResetWB variable triggers Workbook Close Savechanges=false for wbTarg. Default = True 8 | 'bOnlyClear variable triggers storing of shLanding value for error message when False. Default = True 9 | 10 | Dim sUnavailSh As String 11 | 12 | ThisWorkbook.Sheets(shLanding).Activate 13 | 14 | 'disable autofilter if available 15 | If ActiveSheet.AutoFilterMode = True Then 16 | ActiveSheet.AutoFilterMode = False 17 | End If 18 | 19 | If WorksheetFunction.CountA(Cells) <> 0 Then 20 | 'unhide all hidden columns just in case 21 | Columns("A:" & Split(Range(lastCellAdd).Address, "$")(1)).EntireColumn.Hidden = False 22 | Range(Cells(1, 1), Cells(Range(lastCellAdd).Row, Range(lastCellAdd).Column)).Delete 23 | End If 24 | 25 | Cells.NumberFormat = "General" 26 | 27 | If Not wbTarg Is Nothing Then 28 | 29 | 'activate, copy and paste sheet to Macro's sheet 30 | If shTarg = "" Then 31 | wbTarg.Activate 32 | Else 33 | wbTarg.Sheets(shTarg).Activate 34 | End If 35 | 36 | 'disable sheet protection if present 37 | If ActiveSheet.ProtectContents = True Then 38 | ActiveSheet.Unprotect 39 | End If 40 | 41 | 'disable autofilter if available 42 | If ActiveSheet.AutoFilterMode = True Then 43 | ActiveSheet.AutoFilterMode = False 44 | End If 45 | 46 | 'unhide all hidden columns and copy 47 | Columns("A:" & Split(Range(lastCellAdd).Address, "$")(1)).EntireColumn.Hidden = False 48 | Range(Cells(1, 1), Cells(Range(lastCellAdd).Row, Range(lastCellAdd).Column)).Copy 49 | 50 | ThisWorkbook.Sheets(shLanding).Activate 51 | Application.DisplayAlerts = False 52 | Range("A1").PasteSpecial xlPasteAllUsingSourceTheme 53 | 54 | Application.CutCopyMode = False 55 | Application.DisplayAlerts = True 56 | 57 | If bCloseResetWB = True Then 58 | wbTarg.Close savechanges:=False 59 | Set wbTarg = Nothing 60 | End If 61 | 62 | Else 63 | If bOnlyClear = False Then 64 | If sUnavailSh <> "" Then 65 | sUnavailSh = sUnavailSh & ", " & shLanding 66 | Else 67 | sUnavailSh = shLanding 68 | End If 69 | End If 70 | End If 71 | 72 | ThisWorkbook.Sheets(shLanding).Activate 73 | 74 | End Sub 75 | -------------------------------------------------------------------------------- /SendEmailViaVBAMethod1: -------------------------------------------------------------------------------- 1 | Public Sub emailAlgo() 2 | 3 | Dim myGmailAddress As String 4 | Dim myGmailPassword As String 5 | Dim mbMsg As String 6 | Dim mbTitle As String 7 | Dim mbStat As Integer 8 | Dim Mail As New Message 9 | Dim Cfg As Configuration 10 | 11 | ThisWorkbook.Activate 12 | 13 | myGmailAddress = ActiveSheet.OLEObjects("TextBox1").Object.Value 14 | myGmailPassword = ActiveSheet.OLEObjects("TextBox2").Object.Value 15 | 16 | mbMsg = "Confirm that the file to load is the " & ActiveSheet.OLEObjects("TextBox4").Object.Value & "?" 17 | 18 | UserName = myGmailAddress 19 | Password = myGmailPassword 20 | ToAddress = myGmailAddress 21 | Subject = "Test EMAIL from FARIS HADI MSG P1" 22 | 'Subject = "Fwd: Agilent / Keysight and Cisco 02RI ,02RA,02RS,04RB Aging status as of " & Format(Now, "MM/DD/YYY") 23 | HTMLMessage = "Hello All. Attached is the Agilent, Cisco and Keysight 02RI Aging Summary" 24 | SmtpServer = "smtp.gmail.com" 25 | Attachment = ActiveSheet.OLEObjects("TextBox3").Object.Value 26 | 27 | 'CHECK FOR EMPTY AND INVALID PARAMETER VALUES 28 | If Trim(UserName) = "" Or InStr(1, Trim(UserName), "@") = 0 Or Trim(Password) = "" Then 29 | MsgBox "Email or password is unavailable. Please check the fields and try again." 30 | Exit Sub 31 | End If 32 | 33 | If ActiveSheet.OLEObjects("TextBox3").Object.Value = "" Then 34 | MsgBox "No file found! Please re-run the macro to output .jpg file." 35 | Else 36 | mbStat = MsgBox(mbMsg, vbYesNo, mbTitle) 37 | If mbStat = vbNo Then 38 | MsgBox "User cancelled. Program terminate." 39 | End 40 | End If 41 | 42 | 'On Error Resume Next 43 | Set Cfg = Mail.Configuration 44 | 45 | 'SETUP MAIL CONFIGURATION FIELDS 46 | Cfg(cdoSendUsingMethod) = cdoSendUsingPort 47 | Cfg(cdoSMTPServer) = SmtpServer 48 | Cfg(cdoSMTPServerPort) = 465 49 | Cfg(cdoSMTPAuthenticate) = cdoBasic 50 | Cfg(cdoSMTPUseSSL) = True 51 | Cfg(cdoSendUserName) = UserName 52 | Cfg(cdoSendPassword) = Password 53 | Cfg.Fields.Update 54 | 55 | On Error GoTo ErrHandler 56 | With Mail 57 | .From = UserName 58 | .To = ToAddress 59 | .Subject = Subject 60 | .HTMLBody = HTMLMessage 61 | 62 | If Attachment <> "" Then 63 | .AddAttachment Attachment, olByValue, 0 64 | End If 65 | 66 | 'SEND EMAIL 67 | .Send 68 | End With 69 | 70 | MsgBox "Done!" 71 | Exit Sub 72 | 73 | ErrHandler: 74 | MsgBox "Email or password error! Please check and make sure your email and password is correct and try again. Try your previous password (from before your last reset) if you are still unsucessful." 75 | Exit Sub 76 | 77 | End Sub 78 | -------------------------------------------------------------------------------- /SearchFor: -------------------------------------------------------------------------------- 1 | Public Function searchFor(ByVal mytext As String, Optional iSwitchInd As Integer = 1, Optional startRow As Long, Optional endRow As Long, Optional startCol As Integer, Optional endCol As Integer, Optional considerError As Boolean = False) As String 2 | 3 | 'this function looks for the first instance of the provided mytext in the activesheet 4 | 'function allows approximate matching via flipping the iSwitchInd switch 5 | '(1 for full match, 2 for partial matching, 3 for date searches, 4 for searching within a Range) 6 | 'function also allows for triggering of automatic header change in case searchString is not found. (considerError = True) 7 | 8 | Dim found As Range 9 | Dim keepAdd As String 10 | Dim inputCells As Range 11 | 12 | If iSwitchInd = 1 Then 13 | Set found = ActiveSheet.UsedRange.Find(What:=mytext, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, MatchCase:=False) 14 | ElseIf iSwitchInd = 2 Then 15 | Set found = ActiveSheet.UsedRange.Find(What:=mytext, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlRows, MatchCase:=False) 16 | ElseIf iSwitchInd = 3 Then 17 | Set found = ActiveSheet.UsedRange.Find(What:=mytext, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlRows, MatchCase:=False) 18 | ElseIf iSwitchInd = 4 Then 19 | Set found = ActiveSheet.Range(Cells(startRow, startCol), Cells(endRow, endCol)).Find(What:=mytext, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, MatchCase:=False) 20 | End If 21 | 22 | 'if found something 23 | If Not found Is Nothing Then 24 | searchFor = found.Address 25 | 26 | 'else if value not found, 27 | Else 28 | If considerError = True Then 29 | Redo: 30 | On Error GoTo errHandler 31 | Set inputCells = Application.InputBox(prompt:="Cell '" & mytext & "' is not found. Please select the '" & mytext & "' header cell if it exists under another name. Click 'Cancel' to exit.", Title:="Select Header Cells", Type:=8) 32 | 33 | If inputCells.Count > 1 Then 34 | MsgBox "You have selected multiple cells or a whole column/row range. Please reselect only one cell that contains the '" & mytext & "' value." 35 | GoTo Redo 36 | Else 37 | searchFor = inputCells.Address 38 | inputCells.Value = mytext 39 | End If 40 | 41 | Else 42 | searchFor = "X" 43 | End If 44 | End If 45 | Exit Function 46 | 47 | errHandler: 48 | Err.Number = 0 49 | confirmEnd = MsgBox("Confirm Cancel cell header selection? Macro cannot proceed without the correct cell header mappings.", vbYesNo, "ATTENTION") 50 | If confirmEnd = vbYes Then 51 | MsgBox "No values selected. Macro cannot proceed without the correct cell header mappings and will now end. Please re-run macro to try again." 52 | End 53 | Else 54 | Resume Redo 55 | End If 56 | 57 | End Function 58 | -------------------------------------------------------------------------------- /ExplodeStrings: -------------------------------------------------------------------------------- 1 | Public Function ExplodeStrings(ByVal inputString As String) As String 2 | 3 | 'this function take a shorthand string input and splits it into a sequential arrangement 4 | 'Sample string: J12-13 5 | 'Sample output: J12, J13 6 | 7 | Dim x As Long 8 | Dim y As Long 9 | Dim indvParts() As String 10 | Dim sOriginal As String 11 | Dim sModified As String 12 | Dim splitString() As String 13 | Dim splitStart() As String 14 | Dim splitEnd() As String 15 | Dim sStart As String 16 | Dim sEnd As String 17 | Dim sFill As String 18 | Dim lStart As Long 19 | Dim lEnd As Long 20 | Dim sFinal As String 21 | 22 | 'replace new line with space in inputString 23 | inputString = Replace(inputString, Chr(10), " ") 24 | 'replace all commas in inputString, trim the back for extra space, replace errant spaces in front of or behind the "-" symbols 25 | inputString = Replace(Replace(Application.Trim(Replace(inputString, ",", " ")), " -", "-"), "- ", "-") 26 | 27 | 'FARIS > How to handle M-dash or N-dash? Do I need to? 28 | 29 | 'split inputString and push into IndvParts string array 30 | indvParts = Split(inputString) 31 | 32 | 'loop through each indvParts 33 | 'x controls looping through indvParts array 34 | For x = 0 To UBound(indvParts) 35 | 36 | 'if current indvPart has a "-", run separation and sequential increment algorithm 37 | If indvParts(x) Like "*-*" Then 38 | sFinal = "" 39 | sOriginal = indvParts(x) 40 | sModified = Replace(sOriginal, " ", "") 41 | splitString = Split(sModified, "-") 42 | sStart = splitString(0) 43 | sEnd = splitString(1) 44 | 45 | With CreateObject("VBScript.RegExp") 46 | .Pattern = "(\d+|\D+)" 47 | .Global = True 48 | splitStart = Split(Mid(.Replace(sStart, "|$1"), 2), "|") 49 | splitEnd = Split(Mid(.Replace(sEnd, "|$1"), 2), "|") 50 | 51 | 'b = Split(Mid(.Replace("K14L2", "|$1"), 2), "|") 52 | 'FARIS ^ works to split part numbers, use this for enhancement 53 | 54 | 'handle the prefix of the strings 55 | If UBound(splitStart) = 1 Then 56 | sFill = splitStart(0) 57 | Else 58 | sFill = splitStart(0) & splitStart(1) & splitStart(2) 59 | End If 60 | 61 | 'handle incrementing suffix of the strings 62 | lStart = splitStart(UBound(splitStart)) 63 | lEnd = splitEnd(UBound(splitEnd)) 64 | 65 | End With 66 | 67 | For y = lStart To lEnd 68 | If sFinal = "" Then 69 | sFinal = sFill & y 70 | Else 71 | sFinal = sFinal & ", " & sFill & y 72 | End If 73 | Next y 74 | 75 | If ExpandedSeries = "" Then 76 | ExplodeStrings = sFinal 77 | Else 78 | ExplodeStrings = ExplodeStrings & ", " & sFinal 79 | End If 80 | 81 | 'if current indvPart does not have a "-", skip, push into final string and continue on 82 | Else 83 | If ExpandedSeries = "" Then 84 | ExplodeStrings = indvParts(x) 85 | Else 86 | ExplodeStrings = ExplodeStrings & ", " & indvParts(x) 87 | End If 88 | End If 89 | Next x 90 | 91 | End Function 92 | -------------------------------------------------------------------------------- /MultipleSelectMergeWorkbook: -------------------------------------------------------------------------------- 1 | Public Sub MultipleSelectMergeWorkbook() 2 | 3 | Application.ScreenUpdating = False 4 | 5 | Dim lMaxFileNum As Long 6 | Dim fdTargFiles As FileDialog 7 | Dim wbOutput As Workbook 8 | Dim shOutput As Worksheet 9 | Dim wbTarg As Workbook 10 | Dim shTarg As Worksheet 11 | Dim lHeadRow As Long 12 | Dim lLastRow_Output As Long 13 | Dim sFinalWBAdd As String 14 | Dim iGearCol_Output As Integer 15 | 16 | 'initialize variables 17 | ThisWorkbook.Sheets("Macro").Range("C4").Value = "" 18 | lMaxFileNum = 2001 19 | 20 | 'prompt user to select files 21 | Set fdTargFiles = Application.FileDialog(msoFileDialogOpen) 22 | With fdTargFiles 23 | .AllowMultiSelect = True 24 | .Title = "Multi-select target BU files:" 25 | .ButtonName = "" 26 | .Filters.Clear 27 | '.Filters.Add ".xlsx files", "*.xlsx" 28 | .Show 29 | End With 30 | 31 | 'error trap - don't allow user to pick more than 2000 files and check if user selected any files 32 | If fdTargFiles.SelectedItems.Count > lMaxFileNum Then 33 | MsgBox ("Too many files selected, please pick less than " & lMaxFileNum & ". Exiting sub...") 34 | Exit Sub 35 | ElseIf fdTargFiles.SelectedItems.Count = 0 Then 36 | MsgBox ("No files selected! Macro terminated.") 37 | Exit Sub 38 | End If 39 | 40 | 'check if output workbook is already created in the folder. if not, create new one. else delete the old one, run the current. 41 | sFinalWBAdd = fdTargFiles.InitialFileName & "X_" & Format(Date, "mmddyyyy") & ".xlsx" 42 | sCheck = Dir(sFinalWBAdd) 43 | 44 | 'check if previous run is in folder or not 45 | 'if found, confirm delete with user 46 | If sCheck <> "" Then 47 | Kill sFinalWBAdd 48 | End If 49 | 50 | 'set up the output workbook 51 | Set wbOutput = Workbooks.Add 52 | wbOutput.SaveAs Filename:=sFinalWBAdd, FileFormat:=xlOpenXMLWorkbook 53 | 54 | 'loop through all files 55 | For i = 1 To fdTargFiles.SelectedItems.Count 56 | 57 | 'open the file and assign the workbook/worksheet 58 | Application.AskToUpdateLinks = False 59 | Set wbTarg = Workbooks.Open(fdTargFiles.SelectedItems(i)) 60 | Set shTarg = wbTarg.ActiveSheet 61 | Application.AskToUpdateLinks = True 62 | 63 | 'undo filters if present, unhide rows and columns 64 | If ActiveSheet.AutoFilterMode = True Then 65 | ActiveSheet.AutoFilterMode = False 66 | End If 67 | 68 | If WorksheetFunction.CountA(Cells) <> 0 Then 69 | 'unhide all hidden columns just in case 70 | Columns("A:" & Split(Range(lastCellAdd).Address, "$")(1)).EntireColumn.Hidden = False 71 | End If 72 | 73 | 'get header row 74 | lHeadRow = Range(searchFor("Header")).Row 75 | 76 | 'if this is the first go-round, include the header 77 | If i = 1 Then 78 | Range(Cells(lHeadRow, 1), Cells(Range(lastCellAdd).Row, Range(lastCellAdd).Column)).Copy 79 | wbOutput.Sheets(1).Activate 80 | Cells(1, 1).PasteSpecial xlPasteAllUsingSourceTheme 81 | Application.CutCopyMode = False 82 | 83 | 'if this is NOT the first go-round, then skip the header 84 | Else 85 | Range(Cells(lHeadRow + 1, 1), Cells(Range(lastCellAdd).Row, Range(lastCellAdd).Column)).Copy 86 | wbOutput.Sheets(1).Activate 87 | Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteAllUsingSourceTheme 88 | Application.CutCopyMode = False 89 | End If 90 | 91 | 'close the data book without saving 92 | wbTarg.Close savechanges:=False 93 | 94 | Next i 95 | 96 | sFinalWBAdd = fdTargFiles.InitialFileName & "X_" & Format(Date, "mmddyyyy") & ".xlsx" 97 | wbOutput.Close savechanges:=True 98 | 99 | ThisWorkbook.Sheets("Macro").Range("C4").Value = sFinalWBAdd 100 | Application.ScreenUpdating = True 101 | 102 | MsgBox "Files merged!" 103 | 104 | End Sub 105 | -------------------------------------------------------------------------------- /ArrayContainsMatch: -------------------------------------------------------------------------------- 1 | Public Sub ArrayContains() 2 | 3 | '--- 4 | 5 | 'Checks if array contains variable (Exact match and Caps sensitive), returns True/False 6 | Dim aTestArr(0 To 1) As String 7 | aTestArr(0) = "TestString1" 8 | aTestArr(1) = "TestString2" 9 | 10 | a = "TestString1" 11 | b = "UnrelatedString1" 12 | 13 | ArrayContainsReturnsTrue = Not IsError(Application.WorksheetFunction.Match(a, aTestArr, 0)) 14 | ArrayContainsReturnsFalse = Not IsError(Application.WorksheetFunction.Match(b, aTestArr, 0)) 15 | 16 | '--- 17 | 18 | 'match keys from one array to get value from another array 19 | Dim aTestArr2(0 To 1) As String 20 | aTestArr2(0) = "First value" 21 | aTestArr2(1) = "Second value" 22 | 23 | 'this code returns the first value from aTestArr2 as the match returns index 0 from aTestArr 24 | ReturnsFirstValue = aTestArr2(Application.Match(a, aTestArr, 0) - 1) 25 | 26 | '--- 27 | 28 | 'normal match function does not accept multidimensional arrays, so for multidimensional arrays, 29 | 'will need to slice array (with index function) into single dimensional values before matching 30 | 'if we don't know which row/column the value is in, will have to loop while slicing and checking 31 | 'for matches 32 | 33 | Dim aMultiDimTestArr(0 To 1, 0 To 2) As String 34 | aMultiDimTestArr(0, 0) = "TestString00" 35 | aMultiDimTestArr(0, 1) = "TestString01" 36 | aMultiDimTestArr(0, 2) = "TestString02" 37 | aMultiDimTestArr(1, 0) = "TestString10" 38 | aMultiDimTestArr(1, 1) = "TestString11" 39 | aMultiDimTestArr(1, 2) = "TestString12" 40 | 41 | a = "TestString00" 42 | b = "TestString1" 43 | 44 | 'to slice array, use Application.WorksheetFunction.Index(array, rowToSlice, colToSlice) where 45 | 'array : can be an array or range reference (accepts multidimensional array values) 46 | 'rowToSlice : 0 if want to slice by columns, will return all values in rows. Else put row value + 1 from array index reference. 47 | ' eg. if row array index = 0, rowToSlice needs to be 1 to return the same values 48 | 'colToSlice : 0 if want to slice by rows, will return all values in columns. Else put col value + 1 from array index reference. 49 | ' eg. if col array index = 0, colToSlice needs to be 1 to return the same values 50 | 'IMPORTANT NOTE : one of rowToSlice or colToSlice is necessary for slicing, if both = 0, will just return the entire array and the match will not work) 51 | ' 52 | 'reference 1 : https://stackoverflow.com/a/37486990 53 | 'reference 2 : https://docs.microsoft.com/en-us/office/vba/api/excel.worksheetfunction.index 54 | 55 | returnsEntireMultiDimensionalArray = Application.Index(aMultiDimTestArr, 0, 0) 56 | returnsMultiDimensionalArraySlicedByColumn = Application.Index(aMultiDimTestArr, 0, 1) 57 | returnsMultiDimensionalArraySlicedByRow = Application.Index(aMultiDimTestArr, 1, 0) 58 | 59 | 'so if we already know that the value is somewhere in row 0, can just use row = 1 in index row slice to get a match 60 | returnsValue = Application.Match(a, returnsMultiDimensionalArraySlicedByRow, 0) 61 | returnsError = Application.Match(b, returnsMultiDimensionalArraySlicedByRow, 0) 62 | 63 | 'Otherwise, if we want to look through the entire multidimensional array to see if value exists, will have to loop 64 | 'i controls looping through array columns (easier, more values potentially returned and better formatting) 65 | 'loop begins from 1, not 0. Remember, we are looping to change the rowToSlice value, not looping through Array. 66 | resultFoundA = "" 67 | resultNotFoundB = "" 68 | For i = 1 To UBound(aMultiDimTestArr, 2) 69 | 'Match Index will keep erroring until value is found. When it is not an error, that means value is found and loop can be exited. 70 | If Not IsError(Application.Match(a, Application.Index(aMultiDimTestArr, i, 0), 0)) Then 71 | resultFoundA = "String found Array[" & i - 1 & "," & Application.Match("TestString01", Application.Index(aMultiDimTestArr, i, 0), 0) - 1 & "]" 72 | End If 73 | 74 | 'Match Index will keep erroring until value is found. When it is not an error, that means value is found and loop can be exited. 75 | If Not IsError(Application.Match(b, Application.Index(aMultiDimTestArr, i, 0), 0)) Then 76 | resultNotFoundB = "String found Array[" & i - 1 & "," & Application.Match("TestString01", Application.Index(aMultiDimTestArr, i, 0), 0) - 1 & "]" 77 | End If 78 | 79 | Next i 80 | 81 | MsgBox resultFoundA 82 | MsgBox resultNotFoundB 83 | 84 | 85 | End Sub 86 | -------------------------------------------------------------------------------- /VBA_OPTIMIZATION_README: -------------------------------------------------------------------------------- 1 | Optimize Slow VBA Code. Speeding Up Slow Excel VBA Code (Sourced from http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm) 2 | 3 | Avoid the use of Copy and Paste whenever Possible: 4 | Sub NoCopyAndPaste() 5 | 'Instead of: 6 | Sheet1.Range("A1:A200").Copy 7 | Sheet2.Range("B1").pasteSpecial 8 | Application.CutCopyMode=False'Clear Clipboard 9 | 10 | 'Use: 11 | 'By-passes the Clipboard 12 | Sheet1.Range("A1:A200").Copy Destination:=Sheet2.Range("B1") 13 | 14 | 'Or, if only values are needed: 15 | Sheet2.Range("B1:B200").Value= Sheet1.Range("A1:A200").Value 16 | 17 | 'Or, if only formulas are needed: 18 | Sheet2.Range("B1:B200").Formula = Sheet1.Range("A1:A200").Formula 19 | 20 | 'See also FormulaArray and FormulaR1C1 etc 21 | 'Instead of: 22 | Sheet1.Range("A1:A200").Copy 23 | Sheet1.Range("A1:A200").PasteSpecial xlPasteValues 24 | Application.CutCopyMode=False'Clear Clipboard 25 | 26 | 'Use: 27 | Sheet1.Range("A1:A200") = Sheet1.Range("A1:A200").Value 28 | End Sub 29 | 30 | 31 | Speed up code and stop screen flickering: 32 | 33 | Sub NoScreenRePainting() 34 | Application.ScreenUpdating=False 35 | 'Your code here. 36 | Application.ScreenUpdating=True 37 | End Sub 38 | 39 | 40 | Preventing calculation while executing code: 41 | Sub NoCalculations() 42 | Application.Calculation = xlCalculationManual 43 | 'Your code here. 44 | Application.Calculation = xlCalculationAutomatic 45 | End Sub 46 | 47 | 48 | Speeding up code if you have Worksheet or Workbook Events. Also stops endless loops in Events 49 | Sub StopAllEvents() 50 | Application.EnableEvents = False 51 | 'Your code here. 52 | Application.EnableEvents = True 53 | End Sub 54 | 55 | 56 | Use the With Statement when working with Objects. 57 | Sub WithARange() 58 | With Range("A1") 59 | .Value = 100 60 | .Font.Bold = True 61 | .Interior.ColorIndex = 6 62 | .Copy Destination:=Range("B1") 63 | End With 64 | End Sub 65 | 66 | 67 | Use VbNullString instead of = "" When needing to default a String variable back to it's default of "" use: 68 | Sub EmptyText() 69 | Dim strWords As String 70 | strWords = "Cats" 71 | MsgBox strWords 72 | 73 | strWords = vbNullString 74 | MsgBox strWords 75 | End Sub 76 | 77 | 78 | Inserting a Relative formula into a range of cells: Faster than AutoFill or Copy. 79 | Sub NoAutoFillOrCopy() 80 | Range("A1:A200").FormulaR1C1 = "=SUM(RC[1]:RC[5])" 81 | End Sub 82 | 83 | Tip: To get a formula, type it in any cell then select the cell, go Tools>Macro>Record new macro and record a macro pushing F2 then Enter. 84 | 85 | 86 | Always declare your variables correctly! 87 | 88 | To quickly view a variables definition: 89 | Select the variable that you want the definition for. 90 | Go to View>Definition (Shift+F2) 91 | 92 | To return to your previous position: 93 | Go to View>Last Postition (Ctrl+Shift+F2). 94 | 95 | 96 | Release memory from Object variables: 97 | Sub ReleaseObjectMemory() 98 | 99 | 'Could be any variable of the Object type 100 | Dim wSheet as Worksheet 101 | 102 | 'Set Object variable 103 | Set wSheet = Sheet1 104 | 'Your code here. 105 | 106 | 'Release memory 107 | Set wSheet = Nothing 108 | End Sub 109 | 110 | 111 | Don't get caught in the Loop. 112 | Follow this link (http://www.ozgrid.com/VBA/VBALoops.htm) to see why Loops should (and usually can) be avoided. 113 | 114 | Avoid If, Else whenever possible 115 | More often than not people would use an If, Else Statement to test whether a condition is TRUE or FALSE. There is however a slightly faster (and less typing) method. The first example shows the common method, while the second shows a faster method. Of course in such a small example the difference is not noticeable. 116 | 117 | Sub TrueOrFalseSlower() 118 | Dim bYesNo As Boolean 119 | Dim i As Integer 120 | 121 | If i = 5 Then 122 | bYesNo = True 123 | Else 124 | bYesNo = False 125 | End If 126 | MsgBox bYesNo 127 | End Sub 128 | 129 | Here's a better way! 130 | Sub TrueOrFalseFaster() 131 | Dim bYesNo As Boolean 132 | Dim i As Integer 133 | 134 | bYesNo = (i = 5) 135 | MsgBox bYesNo 136 | End Sub 137 | 138 | 139 | Another common need is to toggle a variable between True and False depending on a condition. For example: 140 | Sub ToggleTrueOrFalseSlower() 141 | Dim bYesNo As Boolean 142 | If bYesNo = False Then 143 | bYesNo = True 144 | Else 145 | bYesNo = False 146 | End If 147 | MsgBox bYesNo 148 | End Sub 149 | 150 | Here's a much better way 151 | Sub ToggleTrueOrFalseFaster() 152 | Dim bYesNo As Boolean 153 | bYesNo = Not bYesNo 154 | MsgBox bYesNo 155 | End Sub 156 | -------------------------------------------------------------------------------- /SAPGroupedAlgos: -------------------------------------------------------------------------------- 1 | 'SAPPull & algos variables 2 | Public SapGuiAuto As Object 3 | Public applications As Object 4 | Public Connection As Object 5 | Public session As Object 6 | 7 | 'checkAll variables 8 | Public sCheck As String 9 | 10 | 'preSwitch variables 11 | Public sUnavailWBooks As String 12 | Public sUFormCap As String 13 | 14 | Public Sub SAPPull() 15 | 16 | SAPCheck = MsgBox("You must be logged into SAP to run this macro, failure to do so will produce an error with the macro. Are you logged in to SAP?", vbYesNo, "SAP Login Check") 17 | If SAPCheck = vbNo Then 18 | MsgBox "Please log into SAP and try to run the macro again." 19 | End 20 | End If 21 | 22 | 'Connect to SAP 23 | Set SapGuiAuto = GetObject("SAPGUI") 24 | Set applications = SapGuiAuto.GetScriptingEngine 25 | 26 | 'Check existance of SAP logon screen first before proceed 27 | If applications.Children.Count > 0 Then 28 | Set Connection = applications.Children(0) 29 | 30 | 'SAP is available, run checks before proceeding 31 | Call checkAll 32 | 33 | Else 34 | MsgBox "This macro requires access to the SAP system and no SAP Logon detected. Please logon to SAP system and try again!" 35 | End 36 | End If 37 | 38 | Set session = Connection.Children(0) 39 | 40 | If Not IsObject(applications) Then 41 | Set SapGuiAuto = GetObject("SAPGUI") 42 | Set applications = SapGuiAuto.GetScriptingEngine 43 | End If 44 | 45 | If Not IsObject(Connection) Then 46 | Set Connection = applications.Children(0) 47 | End If 48 | 49 | If Not IsObject(session) Then 50 | Set session = Connection.Children(0) 51 | End If 52 | 53 | If IsObject(WScript) Then 54 | WScript.ConnectObject session, "on" 55 | WScript.ConnectObject applications, "on" 56 | End If 57 | 58 | 'suppress "microsoft office excel is waiting for another application to complete an ole action" error 59 | Application.DisplayAlerts = False 60 | 61 | '************************************************************************************************* 62 | 'SAP Script 63 | '************************************************************************************************* 64 | 65 | 'go back to home screen 66 | session.findById("wnd[0]/tbar[0]/btn[12]").press 67 | 68 | 'unsuppress alerts 69 | Application.DisplayAlerts = True 70 | 71 | Call preSwitch 72 | 73 | End Sub 74 | 75 | Public Sub checkAll() 76 | 77 | Dim aShLocs(0 To 1) As String 78 | aShLocs(0) = "C4" 79 | aShLocs(1) = "G4" 80 | 81 | Dim aShVars(0 To 1) As String 82 | aShVars(0) = "X" 83 | aShVars(1) = "Y" 84 | 85 | 'catches empty workbook selections 86 | For i = 0 To 1 87 | If ThisWorkbook.Sheets("Macro").Range(aShLocs(i)).Value = "" Then 88 | MsgBox "Please select the " & aShVars(i) & " Workbook first by clicking the " & aShVars(i) & """ Browse"" Button before running the macro!" 89 | End 90 | End If 91 | 92 | If ThisWorkbook.Sheets("Macro").OLEObjects("ComboBox" & i - 2).Object.Value = "" Then 93 | MsgBox "Please select the Worksheet for " & aShVars(i) & " Workbook first before running the macro!" 94 | End 95 | End If 96 | 97 | End If 98 | Next i 99 | 100 | 'check if macro location contains workbook name for SAP Pull. Else delete the old one, run the current. 101 | Dim sFName(0 To 1) As String 102 | sFName(0) = "A_" & Format(dEndDate, "mmddyyyy") 103 | sFName(1) = "B_" & Format(dEndDate, "mmddyyyy") 104 | 105 | 'check if previous run is in folder or not 106 | For i = 0 To UBound(sFName) 107 | sCheck = Dir(ThisWorkbook.Path & "\" & sFName(i) & "*") 108 | If sCheck <> "" Then 109 | Kill ThisWorkbook.Path & "\" & sCheck 110 | End If 111 | Next i 112 | 113 | End Sub 114 | 115 | Public Sub preSwitch() 116 | 117 | 'check if macro location contains workbook name for SAP Pull. If does not exist prompt confirmation 118 | Dim aWBNames(0 To 4) As String 119 | aWBNames(0) = "A_" & Format(dEndDate, "mmddyyyy") 120 | aWBNames(1) = "B_" & Format(dEndDate, "mmddyyyy") 121 | 122 | 'for each unavailable workbook, push name into variable container to display on userform 123 | sCurrWBPath = ThisWorkbook.Path 124 | 'i controls looping through workbook names array 125 | For i = 0 To UBound(aWBNames) 126 | If Dir(sCurrWBPath & "\" & aWBNames(i) & "*") = "" Then 127 | If sUnavailWBooks <> "" Then 128 | sUnavailWBooks = sUnavailWBooks & ", " & aWBNames(i) 129 | Else 130 | sUnavailWBooks = aWBNames(i) 131 | End If 132 | End If 133 | Next i 134 | 135 | 'assign caption for userform 136 | If sUnavailWBooks <> "" Then 137 | sUFormCap = "There are workbooks (" & sUnavailWBooks & ") that are missing from the SAP pull. " & _ 138 | "Do you wish to disregard the missing workbooks (and ignore the algorithms that affect them) and continue?" 139 | Else 140 | sUFormCap = "Perfect SAP Pull! There are no workbooks missing. Do you wish to continue with the macro?" 141 | End If 142 | 143 | With UserForm1 144 | .Label1.Caption = sUFormCap 145 | .Label2.Caption = dEndDate 146 | .Show 147 | End With 148 | 149 | End Sub 150 | -------------------------------------------------------------------------------- /SendEmailViaVBAMethod2: -------------------------------------------------------------------------------- 1 | Public Sub callingEmailAlgo() 2 | 3 | Dim imgEmbedComm, imgObject 4 | Dim tXtboxSrce As String 5 | Dim mbMsg As String 6 | Dim locations As String 7 | Dim flag As Boolean 8 | 9 | flag = False 10 | 11 | fromAdd = ActiveSheet.OLEObjects("TextBox1").Object.Value 12 | toAdd = ActiveSheet.OLEObjects("TextBox5").Object.Value 13 | 14 | 'get locations 15 | For i = 1 To 10 16 | If ActiveSheet.OLEObjects("CheckBox" & i).Object.Value = True Then 17 | flag = True 18 | Exit For 19 | End If 20 | Next i 21 | 22 | If flag = True Then 23 | For i = 1 To 10 24 | If i = 1 And ActiveSheet.OLEObjects("CheckBox" & i).Object.Value = True Then 25 | locations = ActiveSheet.OLEObjects("CheckBox" & i).Object.Caption 26 | ElseIf i <> 1 And ActiveSheet.OLEObjects("CheckBox" & i).Object.Value = True Then 27 | locations = locations & ", " & ActiveSheet.OLEObjects("CheckBox" & i).Object.Caption 28 | End If 29 | Next i 30 | Else 31 | MsgBox "Checkbox ERROR! If you have accidentally unchecked the checkboxes, please re-check them. The macro needs the values from the checkboxes to compose the email." 32 | End 33 | End If 34 | 35 | subj = "Fwd: Agilent / Keysight and Cisco " & locations & " Aging status as of " & Format(Now, "MM/DD/YYYY") 36 | mbMsg = "Confirm that the file to load is the " & ActiveSheet.OLEObjects("TextBox4").Object.Value & ".jpg?" 37 | tXtboxSrce = ActiveSheet.OLEObjects("TextBox3").Object.Value 38 | 39 | 'Check if the file is really the one you want to upload as attachment 40 | If tXtboxSrce = "" Then 41 | MsgBox "No file found! Please re-run the macro to output .jpg file." 42 | End 43 | Else 44 | mbStat = MsgBox(mbMsg, vbYesNo, mbTitle) 45 | If mbStat = vbNo Then 46 | MsgBox "User cancelled. Program terminate." 47 | End 48 | End If 49 | End If 50 | 51 | imgEmbedComm = """ />" 52 | htmlBodyCont = "Hello All. Attached is the Agilent, Cisco and Keysight 02RI Aging Summary" & imgEmbedComm 53 | 54 | Set imgObject = PrepareMessageWithEmbeddedImages(fromAdd, toAdd, subj, htmlBodyCont) 55 | 56 | SmtpServer = "smtp.gmail.com" 57 | SmtpPort = 465 58 | UserName = fromAdd 59 | Password = ActiveSheet.OLEObjects("TextBox2").Object.Value 60 | 61 | 'Check to ensure username and passwords are present 62 | If Trim(UserName) = "" Or InStr(1, Trim(UserName), "@") = 0 Or InStr(1, Trim(toAdd), "@") = 0 Or Trim(Password) = "" Then 63 | MsgBox "Email or password is unavailable. Please check the fields and try again." 64 | End 65 | End If 66 | 67 | SendMessageBySMTP imgObject, SmtpServer, SmtpPort, UserName, Password, True 68 | 69 | End Sub 70 | 71 | Public Function PrepareMessageWithEmbeddedImages(ByVal FromAddress, ByVal ToAddress, ByVal Subject, ByVal HtmlContent) 72 | 73 | Dim Message, Attachment, Expression, Matches, FilenameMatch, i 74 | 75 | Set Expression = CreateObject("VBScript.RegExp") 76 | Expression.Pattern = "\" 77 | Expression.IgnoreCase = True 78 | Expression.Global = False 'one match at a time 79 | 80 | Set Message = CreateObject("CDO.Message") 81 | Message.From = FromAddress 82 | Message.To = ToAddress 83 | Message.Subject = Subject 84 | '***** ****** ***** ***** ***** 85 | Message.AddAttachment ThisWorkbook.Path & "\" & ActiveSheet.OLEObjects("TextBox4").Object.Value & ".xlsx" 86 | '***** ****** ***** ***** ***** 87 | 88 | 'Find matches in email body, incrementally increasing the auto-assigned attachment identifiers 89 | i = 1 90 | While Expression.test(HtmlContent) 91 | FilenameMatch = Expression.Execute(HtmlContent).Item(0).SubMatches(0) 92 | Set Attachment = Message.AddAttachment(FilenameMatch) 93 | Attachment.Fields.Item("urn:schemas:mailheader:Content-ID") = "" ' set an ID we can refer to in HTML 94 | Attachment.Fields.Item("urn:schemas:mailheader:Content-Disposition") = "inline" ' "hide" the attachment 95 | Attachment.Fields.Update 96 | HtmlContent = Expression.Replace(HtmlContent, "cid:attachedimage" & i) ' update the HTML to refer to the actual attachment 97 | i = i + 1 98 | Wend 99 | 100 | Message.HTMLBody = HtmlContent 101 | Set PrepareMessageWithEmbeddedImages = Message 102 | 103 | End Function 104 | 105 | Public Function SendMessageBySMTP(ByRef Message, ByVal SmtpServer, ByVal SmtpPort, ByVal SmtpUsername, ByVal SmtpPassword, ByVal UseSSL) 106 | 107 | Dim Configuration 108 | Set Configuration = CreateObject("CDO.Configuration") 109 | Configuration.Load -1 ' CDO Source Defaults 110 | Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 111 | Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SmtpServer 112 | Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SmtpPort 113 | 114 | If SmtpUsername <> "" Then 115 | Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 116 | Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SmtpUsername 117 | Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SmtpPassword 118 | End If 119 | 120 | Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = UseSSL 121 | Configuration.Fields.Update 122 | 123 | Set Message.Configuration = Configuration 124 | On Error GoTo ErrHandler 125 | Message.Send 126 | 127 | MsgBox "Done!" 128 | 129 | Exit Function 130 | 131 | ErrHandler: 132 | MsgBox "Email or password error! Please check and make sure your email and password is correct and try again. Try your previous password (from before your last reset) if you are still unsucessful." 133 | End 134 | 135 | End Function 136 | -------------------------------------------------------------------------------- /SendEmailViaVBAMethod4: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "HTML_Convertor" 2 | Sub generateHTMLEmail(ByVal nTxtBox As Integer) 3 | Dim testShape As Shape 4 | Set mainWSD = ThisWorkbook.Sheets("Macro") 5 | Set testShape = mainWSD.Shapes("txtTest") 6 | testShape.TextFrame.Characters.Text = " " 7 | 8 | Call convertBoxToHTML("txtBody" & nTxtBox) 9 | testShape.TextFrame.Characters.Text = testShape.TextFrame.Characters.Text & "

" 10 | Call convertBoxToHTML("txtSignature1") 11 | 12 | testShape.TextFrame.Characters.Text = testShape.TextFrame.Characters.Text & " " 13 | End Sub 14 | Sub test() 15 | 'Set a = Sheets("Macro").Shapes("txtTest") 16 | Sheets("Macro").Shapes("txtTest").Visible = False 17 | End Sub 18 | Function biuText(ByVal nStr As String, ByVal B As Boolean, ByVal i As Boolean, ByVal u As Boolean) As String 19 | 'HTML Bold, Italic, Underline 20 | Dim nOut As String 21 | nOut = nStr 22 | If B Then nOut = "" & nOut & "" 23 | If i Then nOut = "" & nOut & "" 24 | If u Then nOut = "" & nOut & "" 25 | biuText = nOut 26 | End Function 27 | 28 | Sub HTMLConvertor(ByVal sLen As Single, ByVal eLen As Single, ByVal txtBoxName As String) 29 | 'Convert text to HTML then append into txtTest TextBox 30 | 31 | Dim nLen As Single, tLen As Single, contLen As Single 32 | Dim tempOut As String 33 | Dim txtShape As Shape, testShape As Shape 34 | Dim B As Boolean, i As Boolean, u As Boolean 35 | Dim nStr As String, fontName As String, hexColor As String 36 | Dim fontSize As Single, colorCode As Single 37 | 38 | Set mainWSD = ThisWorkbook.Sheets("Macro") 39 | Set txtShape = mainWSD.Shapes(txtBoxName) 40 | Set testShape = mainWSD.Shapes("txtTest") 41 | 42 | tLen = Len(txtShape.TextFrame.Characters(Start:=sLen, Length:=eLen).Text) 43 | If tLen = 0 Then Exit Sub 44 | 45 | contLen = Len(testShape.TextFrame.Characters.Text) 46 | fontSize = Application.RoundUp((txtShape.TextFrame.Characters(Start:=sLen, Length:=eLen).Font.Size / 12 * 3), 0) 47 | fontName = txtShape.TextFrame.Characters(Start:=sLen, Length:=eLen).Font.Name 48 | colorCode = CSng(txtShape.TextFrame.Characters(Start:=sLen, Length:=eLen).Font.Color) 49 | hexColor = ColorConvertor(colorCode) 50 | 51 | tempOut = "" 52 | 53 | If txtShape.TextFrame.Characters(Start:=sLen, Length:=eLen).Font.Bold = True Then B = True 54 | If txtShape.TextFrame.Characters(Start:=sLen, Length:=eLen).Font.Italic = True Then i = True 55 | If txtShape.TextFrame.Characters(Start:=sLen, Length:=eLen).Font.Underline = "2" Then u = True 56 | nStr = txtShape.TextFrame.Characters(Start:=sLen, Length:=eLen).Text 57 | tempOut = tempOut & biuText(nStr, B, i, u) 58 | 59 | tempOut = tempOut & "" 60 | 61 | tempOut = Replace(tempOut, vbLf, "
") 62 | tempOut = Replace(tempOut, " ", "  ") 63 | 64 | contLen = Len(testShape.TextFrame.Characters.Text) 65 | testShape.TextFrame.Characters(Start:=contLen).Text = tempOut & " " 66 | 67 | End Sub 68 | 69 | Sub convertBoxToHTML(ByVal txtBoxName As String) 70 | 71 | Dim txtBox As String 72 | Dim nLen As Single, sLen As Single, eLen As Single, tLen As Single, contLen As Single 73 | Dim setting As String, setting1 As String, setting2 As String, nUnderline As String 74 | Dim nBold As Boolean, nItalic As Boolean 75 | Dim nSize As String, nFont As String, nColor As String 76 | Dim txtShape As Shape, testShape As Shape 77 | 78 | txtBox = txtBoxName 79 | 80 | Set mainWSD = ThisWorkbook.Sheets("Macro") 81 | Set txtShape = mainWSD.Shapes(txtBox) 82 | 83 | tLen = Len(txtShape.TextFrame.Characters.Text) 84 | If tLen = 0 Then Exit Sub 85 | eLen = 0 86 | sLen = 1 87 | setting1 = "" 88 | setting2 = "" 89 | For nLen = 1 To tLen 90 | 91 | nBold = txtShape.TextFrame.Characters(Start:=nLen, Length:=1).Font.Bold 92 | nItalic = txtShape.TextFrame.Characters(Start:=nLen, Length:=1).Font.Italic 93 | nUnderline = txtShape.TextFrame.Characters(Start:=nLen, Length:=1).Font.Underline 94 | nColor = txtShape.TextFrame.Characters(Start:=nLen, Length:=1).Font.Color 95 | nSize = CStr(txtShape.TextFrame.Characters(Start:=nLen, Length:=1).Font.Size) 96 | nFont = txtShape.TextFrame.Characters(Start:=nLen, Length:=1).Font.Name 97 | 98 | 'setting = setting & "D" 99 | If nBold = True Then setting = setting & "B" 100 | 'setting = setting & "L" 101 | If nItalic = True Then setting = setting & "I" 102 | 'setting = setting & "V" 103 | If nUnderline = "2" Then setting = setting & "U" 104 | 105 | setting = setting & nColor 106 | setting = setting & nSize 107 | setting = setting & nFont 108 | 109 | setting1 = setting 110 | If setting2 = "" Then setting2 = setting 111 | setting = "" 112 | 113 | If txtShape.TextFrame.Characters(Start:=nLen, Length:=1).Text = vbLf Then 114 | Call HTMLConvertor(sLen, eLen, txtBox) 115 | sLen = nLen 116 | eLen = 1 117 | setting2 = setting1 118 | Else 119 | If setting1 <> setting2 Then 120 | Call HTMLConvertor(sLen, eLen, txtBox) 121 | sLen = nLen 122 | eLen = 1 123 | setting2 = setting1 124 | Else 125 | eLen = eLen + 1 126 | End If 127 | End If 128 | 129 | If nLen = tLen Then 130 | Call HTMLConvertor(sLen, eLen, txtBox) 131 | End If 132 | Next 133 | 134 | End Sub 135 | --------------------------------------------------------------------------------