Repository: Vitosh/VBA_personal Branch: master Commit: 07f4aaaaea70 Files: 279 Total size: 518.8 KB Directory structure: gitextract_tbkq5rr1/ ├── .gitattributes ├── .gitignore ├── Algorithms/ │ ├── ActivitySelectionProblem.vb │ ├── ActivitySelectionProblem_clsActivity.vb │ ├── AlgorithmsTesting/ │ │ ├── Modul1.bas │ │ ├── ReadMe.md │ │ ├── Result001.txt │ │ ├── Result002.txt │ │ ├── Test001.txt │ │ └── Test002.txt │ ├── CryptographyHashing/ │ │ ├── Base64Sha1.bas │ │ └── string_to_hash.py │ ├── FillNumbersInGivenRange.vb │ ├── Games/ │ │ ├── SnakeAttempt.vb │ │ └── SnakePrinting.vb │ ├── GoRightAndDown.vb │ ├── Knight.vb │ ├── Knight.xlsm │ ├── LongestIncreasingSubsequence.vb │ ├── NpComplete/ │ │ ├── NestedLoops.vb │ │ ├── RecursionLoops.vb │ │ └── readme.md │ ├── PwdHacks/ │ │ ├── CrackerJack.vb │ │ ├── GhostBreakInfo.vb │ │ └── Xlsb.PasswordRemover.vb │ ├── QueenDrama.vb │ ├── StringManipulations.vb │ ├── TaxiCabNumbers.vb │ └── TraverseGraph.vb ├── Boilerplate/ │ ├── ApplicationOnKey.vb │ ├── Boilerplate VitoshAcademy/ │ │ ├── ConstantsAndPublic.bas │ │ ├── ExcelAdditional.bas │ │ ├── ExcelDates.bas │ │ ├── ExcelFormatCell.bas │ │ ├── ExcelLastThings.bas │ │ ├── ExcelPrintToNotepad.bas │ │ ├── ExcelStructure.bas │ │ ├── ExcelVBE.bas │ │ ├── VersionsAbout.bas │ │ ├── formExample.bas │ │ ├── formSummaryPresenter.cls │ │ ├── frmExample.frm │ │ ├── frmExample.frx │ │ ├── frmInfo.frm │ │ ├── frmInfo.frx │ │ ├── tblInput.vb │ │ ├── tddMain.bas │ │ ├── tddSpecDefinition.cls │ │ ├── tddSpecExpectation.cls │ │ ├── tddSpecInlineRunner.bas │ │ ├── tddSpecSuite.cls │ │ └── xl_main.vb │ ├── Boilerplate_v8.0.3.xlsb │ ├── CodifyDecodify.vb │ ├── ConvertNumberToLetter.vb │ ├── ExcelGeneral.vb │ ├── Files.vb │ ├── Formula.vb │ ├── GeneratePathToFolder.vb │ ├── LastThings.vb │ ├── Lock.vb │ ├── MinAndMax.vb │ ├── NamedRanges.vb │ ├── NotepadExport.vb │ ├── OnStartOnEnd.vb │ ├── RegEx.vb │ ├── StringsAlgorithms.vb │ ├── Timer.vb │ ├── VariousDatesFirstDay.vb │ ├── WorksheetToCSV │ └── readme.md ├── ExcelTdd/ │ ├── ExcelTDD.xlsb │ ├── InlineRunner.vb │ ├── MakeValuesSelection.vb │ ├── README.md │ ├── SpecDefinition.vb │ ├── SpecExpectation.vb │ ├── SpecSuite.vb │ ├── TDD_example.vb │ ├── mod_NeutralSubsAndRoutines.vb │ ├── mod_Notepad.vb │ ├── mod_PublicVariables.vb │ ├── mod_TddRoutines.vb │ └── mod_TddRoutinesB.vb ├── Financial/ │ ├── BenfordModule.vb │ ├── BenfordModuleClass.vb │ ├── BenfordTableTennisData.xlsb │ ├── Binary.vb │ ├── ByReferenceByValue.vb │ ├── CalculateCostsWithInflation.vb │ ├── DoubleCalculation.vb │ ├── ExampleWithDoubles.vb │ ├── MakeRedAndBlack.vb │ ├── Readme.md │ ├── ScientificNotationExplanation.vb │ ├── SumProductCountAndSum.xlsx │ └── VLookUpWithMultipleCriteria.vb ├── Formatting/ │ ├── Borders.vb │ ├── ColorSaturdayAndSunday.vb │ ├── Comments.vb │ ├── Conditional Compilation Arguments.vb │ ├── ConditionalFormat.vb │ ├── CreateSheetRemoveSheet.vb │ ├── DataCleaning.vb │ ├── FileNameWithDialogBox.vb │ ├── FixRangeError.vb │ ├── GetWorkbook.vb │ ├── IgnoreCellErrors.vb │ ├── InsertIntoString.vb │ ├── OpenAndClose.vb │ ├── RangeConnector.vb │ ├── RemoveWorksheet.vb │ ├── Rgb2HtmlColor.vb │ ├── SetPrintArea.vb │ ├── Shapes.vb │ ├── Shortcuts/ │ │ ├── README.md │ │ └── Shortcuts.xlsx │ ├── SplitValuesSingleColumnToCells.vb │ └── StyleKiller.vb ├── Internet/ │ ├── AmazonInternet.bas │ ├── ConstValues.bas │ ├── ExcelRelated.bas │ ├── General.bas │ ├── GotoInternet.vb │ ├── README.md │ ├── StartUp.bas │ └── XL.xlsb ├── OOP/ │ ├── AttributesInVBA/ │ │ ├── CarGlobal.cls │ │ ├── CarWithDefaultProperty.cls │ │ ├── ExportModule.bas │ │ ├── MainModule.bas │ │ ├── ReadMe.md │ │ └── TruckWithDefaultProcedure.cls │ ├── CopyObjectInVBA/ │ │ ├── Employee.cls.txt │ │ ├── MainModule.vb.txt │ │ └── ReadMe.md │ ├── DictionaryAndArray/ │ │ ├── CollectionToArray.vb │ │ ├── DictionaryExample.vb │ │ ├── HttpObjectInTag.vb │ │ ├── Internet.vb │ │ ├── MultidimensionalArray.vb │ │ ├── RemoveEmptyElementsFromArray.vb │ │ └── SortArraySortList.vb │ └── Interfaces/ │ ├── IGeneral.vb │ ├── IUnitTypes.vb │ ├── cls_beide.vb │ ├── cls_carport.vb │ ├── cls_gewerbe.vb │ ├── cls_tg.vb │ ├── cls_wohnungen.vb │ ├── mod_main.vb │ └── mod_test.vb ├── PythonExcel/ │ ├── ReadMe.md │ └── list_to_multiple_tabs.py ├── README.md ├── Sql/ │ ├── CheckStatus.vb │ ├── Connection.vb │ ├── ExportFromMssqlToExcel.vb │ ├── ImportToMSSQL.vb │ ├── SQL_Local_Info.vb │ ├── SQL_VBA01.vb │ ├── SQL_VBA02.vb │ ├── SQL_VBA03.vb │ ├── SqlQueriesVBA/ │ │ ├── AdoValueConverter.cls │ │ └── SqlCommand.cls │ ├── mdx.vb │ ├── sql_test.vb │ └── sql_vba_excel.vb ├── VBE/ │ ├── AddOptionPrivateModule.vb │ ├── GitSave.vb │ ├── MovingModules.vb/ │ │ ├── ThisSheet.vb │ │ ├── ThisWorkbook.vb │ │ ├── cls_calendar.vb │ │ ├── mod_gen_main.vb │ │ ├── mod_gen_public.vb │ │ ├── mod_main.vb │ │ └── mod_public.vb │ ├── Preprocessor.vb │ ├── PrintAllProcedures.vb │ └── SaveThis.vb ├── XML/ │ ├── XmlSimpleManualParser.txt │ ├── readme.md │ └── test.xml └── __Arch/ ├── 00.vb ├── 01.vb ├── 03.vb ├── 04 - Excel Objects Edition.vb ├── AllFormats.vb ├── AverageRowColumnNamedRange.vb ├── BorderMeBorderRange.vb ├── Classes/ │ ├── Class Builder VBA/ │ │ ├── cls_ba.cls │ │ ├── cls_project.cls │ │ └── mod_main.bas │ ├── class-project/ │ │ ├── Call By Names │ │ ├── check_properties.vb │ │ ├── cls_arrCalendarSettings.vb │ │ ├── cls_arr_Choice.vb │ │ ├── mod_Properties.vb │ │ ├── mod_PublicAndEnums │ │ └── mod_current.vb │ ├── class-project-customized/ │ │ └── customized_procedure.vb │ └── class-project-improved/ │ ├── cls_arrCalendar.vb │ ├── cls_arrChoice.vb │ └── sandbox.vb ├── FixSums.vb ├── FormWithAnInstanceVBA/ │ ├── Form001.xlsb │ ├── Form003/ │ │ ├── clsSummaryPresenter.vb │ │ ├── frmMain.vb │ │ └── modMain.vb │ ├── Form011_working.xlsb │ ├── clsSummaryPresenter.vb │ ├── frmMain.vb │ └── modMain.vb ├── FormatMyCell.vb ├── Hex.vb ├── HideRange.vb ├── HideShowComments.vb ├── NamedRanges.vb ├── OpenedExcelInfo.vb ├── OutlookRelated.vb ├── Recursion.vb ├── RelativePath.vb ├── RemoveAllItemsFromListBox.vb ├── SaveAs.vb ├── SmallExcelFormats.vb ├── TDD_example.vb ├── UseEnvironName.vb ├── Userful_Application.vb ├── XL_password_cracker.vb ├── addPictureToFile.vb ├── all_of_a_kind.vb ├── browse.vb ├── btn_open_Click.vb ├── bus.vb ├── call_click_event_from_module.vb ├── cls_counter.vb ├── code_making_code.vb ├── colors.vb ├── copy_newsheet_new sheet.vb ├── delete_row.vb ├── errors.vb ├── example.hta.htm ├── form_VBA.vb ├── general_smalls.vb ├── hide_selected_sheets.vb ├── info.txt ├── isUserFormLoaded.vb ├── languages.vb ├── last_row_of_named_range.vb ├── mod_cumulative_sum.vb ├── mod_environ.vb ├── mod_excel_functions.vb ├── mod_from_experience_various.vb ├── mod_functions.vb ├── mod_public.vb ├── mod_remove_styles.vb ├── mod_shortcuts.vb ├── proposal_to_update.vb ├── protectsheet.vb ├── quick_unlock.vb ├── readme.md ├── recursive_loop.vb ├── refer_cell_in_named_range.vb ├── relevant_months.vb ├── removeNamedRanges.vb ├── remove_msgbox.txt ├── remove_spaces.vb ├── revealer.vb ├── selection_range_trick.vb ├── string_generator.vb ├── subsequence.vb ├── sum_array_with_optional.vb ├── sum_column.vb ├── todo_in_a_new_project.vb ├── typenameAndvartype.vb ├── user_form_centre.vb ├── vba_dictionary_example.vb ├── xl_docName.vb └── xl_main.vb ================================================ FILE CONTENTS ================================================ ================================================ FILE: .gitattributes ================================================ *.vb linguist-language=vba ================================================ FILE: .gitignore ================================================ # Compiled source # ################### *.com *.class *.dll *.exe *.o *.so # Packages # ############ # it's better to unpack these files and commit the raw source # git has its own built in compression methods *.7z *.dmg *.gz *.iso *.jar *.rar *.tar *.zip # Logs and databases # ###################### *.log *.sql *.sqlite # OS generated files # ###################### .DS_Store .DS_Store? ._* .Spotlight-V100 .Trashes ehthumbs.db Thumbs.db desktop.ini ================================================ FILE: Algorithms/ActivitySelectionProblem.vb ================================================ Option Explicit Public Sub TestMe() Dim objA As clsActivity Dim colObjs As New Collection Dim rngCell As Range Dim strResult As String Dim i As Long Dim lngNextStart As Long: lngNextStart = 0 For Each rngCell In Range(Cells(1, 1), Cells(1, 11)) Set objA = Nothing Set objA = New clsActivity objA.StartTime = rngCell objA.EndTime = rngCell.Offset(1, 0) objA.Name = rngCell.Offset(2, 0) colObjs.Add objA Next rngCell Set colObjs = SortedCollection(colObjs) For i = 1 To colObjs.Count If colObjs.Item(i).StartTime > lngNextStart Then strResult = strResult & colObjs.Item(i).Name & vbTab & _ colObjs.Item(i).StartTime & vbTab & _ colObjs.Item(i).EndTime & vbCrLf lngNextStart = colObjs.Item(i).EndTime End If Next i Debug.Print strResult End Sub Public Function SortedCollection(myColl As Collection, Optional blnSortABC As Boolean = True) As Collection Dim i As Long Dim j As Long For i = myColl.Count To 2 Step -1 For j = 1 To i - 1 If blnSortABC Then If myColl(j).EndTime > myColl(j + 1).EndTime Then myColl.Add myColl(j), after:=j + 1 myColl.Remove j End If Else If myColl(j).EndTime < myColl(j + 1).EndTime Then myColl.Add myColl(j), after:=j + 1 myColl.Remove j End If End If Next j Next i Set SortedCollection = myColl End Function ================================================ FILE: Algorithms/ActivitySelectionProblem_clsActivity.vb ================================================ Private pName As String Private pStartTime As Long Private pEndTime As Long Public Property Get Name() As String Name = pName End Property Public Property Let Name(value As String) pName = value End Property Public Property Get StartTime() As Long StartTime = pStartTime End Property Public Property Let StartTime(value As Long) pStartTime = value End Property Public Property Get Endtime() As Long Endtime = pEndTime End Property Public Property Let Endtime(value As Long) pEndTime = value End Property ================================================ FILE: Algorithms/AlgorithmsTesting/Modul1.bas ================================================ Attribute VB_Name = "Modul1" Option Explicit Public Sub Main() Dim totalTests As Long Dim pathInputTests As String Dim pathOutputTests As String Dim inputTests As Variant Dim outputTests As Variant Dim cntTests As Long Dim cnt As Long pathInputTests = "C:\Desktop\Test002.txt" pathOutputTests = "C:\Desktop\Result002.txt" inputTests = Split(ReadFileLineByLineToString(pathInputTests), vbCrLf) outputTests = Split(ReadFileLineByLineToString(pathOutputTests), vbCrLf) For cnt = LBound(inputTests) To UBound(inputTests) Dim expectedValue As Variant Dim receivedValue As Variant On Error Resume Next expectedValue = outputTests(cnt) receivedValue = MainTest(Trim(inputTests(cnt))) If Err.Number <> 0 Then Debug.Print runtimeError(cnt) Err.Clear Else If Trim(expectedValue) = Trim(receivedValue) Then Debug.Print positiveResult(cnt) Else Debug.Print negativeResult(cnt, expectedValue, receivedValue) End If End If Next cnt End Sub Public Function runtimeError(ByVal cnt As Long) As String cnt = cnt + 1 runtimeError = "Runtime error on " & cnt & "!" End Function Public Function positiveResult(ByVal cnt As Long) As String cnt = cnt + 1 positiveResult = "Test " & cnt & "..................................... ok!" End Function Public Function negativeResult(ByVal cnt As Long, expected As Variant, _ received As Variant) As String cnt = cnt + 1 negativeResult = "Error on test " & cnt & "!" & _ " Expected -> " & vbTab & expected & vbTab & _ " Received -> " & vbTab & received End Function '--------------------------------------------------------------------------------------- ' Method : MainTest ' Purpose: This is where the competitors paste their solution. '--------------------------------------------------------------------------------------- Public Function MainTest(ByVal consoleInput As String) As String Dim inputVar As Variant Dim cnt As Long Dim outputVar As Variant inputVar = Split(consoleInput) ReDim outputVar(UBound(inputVar)) For cnt = LBound(inputVar) To UBound(inputVar) If Asc(inputVar(cnt)) = Asc("z") Then MainTest = MainTest & " a" Else MainTest = MainTest & " " & Chr(Asc(inputVar(cnt)) + 1) End If Next cnt ' Dim a As Double ' Dim b As Double ' Dim c As Double ' ' a = Split(consoleInput)(0) ' b = Split(consoleInput)(1) ' c = Split(consoleInput)(2) ' ' If c Mod 2 = 0 Then ' MainTest = a + b + c ' Else ' MainTest = a + b - c ' End If End Function Public Function ReadFromFile(path As String) As String Dim fileNo As Long fileNo = FreeFile Open path For Input As #fileNo Do While Not EOF(fileNo) Dim textRowInput As String Line Input #fileNo, textRowInput ReadFromFile = ReadFromFile & textRowInput If Not EOF(fileNo) Then ReadFromFile = ReadFromFile & vbCrLf End If Loop Close #fileNo End Function Sub WriteToFile(filePath As String, text As String) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim oFile As Object Set oFile = fso.CreateTextFile(filePath) oFile.Write text oFile.Close End Sub Sub TestMe() Dim readTxt As String Dim filePath As String: filePath = "C:\text.txt" readTxt = ReadFromFile(filePath) readTxt = Replace(readTxt, "name=", "") readTxt = Replace(readTxt, "correo=", "") WriteToFile filePath, readTxt End Sub ================================================ FILE: Algorithms/AlgorithmsTesting/ReadMe.md ================================================ # Algorithm testing system, reading from text file with VBA For the people, familiar with my blog, it is known that usually I am resolving problems from Codeforces.com. Codeforces supports plenty of languages, unfortunately VBA is not one of them. Thus, I have decided to build up a small algorithm testing system, which follows the following pattern – the input and the expected output are both provided via separate text files. Then, the person who writes the algorithm, should be able to write a function, reading from the first file and getting exactly the values from the other file. Thus, let’s imagine that the task sounds like: Take an input of 3 numbers and sum them. However, if the third number is even, do sum only the first two and subtract the third. This is easily achievable through this function (...) The whole article is available @ [VitoshAcademy](http://www.vitoshacademy.com/algorithm-testing-system-reading-from-text-file-with-vba/) ================================================ FILE: Algorithms/AlgorithmsTesting/Result001.txt ================================================ 6 1 1 58 100 121 100 ================================================ FILE: Algorithms/AlgorithmsTesting/Result002.txt ================================================ b c d e f g c a d d a a b ================================================ FILE: Algorithms/AlgorithmsTesting/Test001.txt ================================================ 2 2 2 2 2 2 2 3 4 54 1 2 2 54 23 6 45 45 10 ================================================ FILE: Algorithms/AlgorithmsTesting/Test002.txt ================================================ a b c d e f b z c c z z a ================================================ FILE: Algorithms/CryptographyHashing/Base64Sha1.bas ================================================ Public Function Base64Sha1(inputText As String, Optional secretKey = "") As String Dim asc As Object Dim enc As Object Dim textToHash() As Byte Dim SharedSecretKey() As Byte Dim bytes() As Byte If secretKey = "" Then secretKey = inputText Set asc = CreateObject("System.Text.UTF8Encoding") Set enc = CreateObject("System.Security.Cryptography.HMACSHA1") textToHash = asc.GetBytes_4(inputText) SharedSecretKey = asc.GetBytes_4(secretKey) enc.Key = SharedSecretKey bytes = enc.ComputeHash_2((textToHash)) Base64Sha1 = EncodeBase64(bytes) End Function Private Function EncodeBase64(arrData() As Byte) As String Dim objXML As Object Dim objNode As Object Set objXML = CreateObject("MSXML2.DOMDocument") Set objNode = objXML.createElement("b64") objNode.DataType = "bin.base64" objNode.nodeTypedValue = arrData EncodeBase64 = objNode.text End Function Sub TestMe() Debug.Print Base64Sha1("asdf", "ThisIsTheSecretKey") = "DSmGEC8dUW9xRs+YfAPji59dxCM=" Debug.Print Base64Sha1("asdf") = "qIQmNGgreJRqJroWUUu0MxLq2oo=" Debug.Print Base64Sha1("asdf", "asdf") = "qIQmNGgreJRqJroWUUu0MxLq2oo=" End Sub ================================================ FILE: Algorithms/CryptographyHashing/string_to_hash.py ================================================ import hmac import hashlib import base64 def string_to_hash(word): word = word.encode('utf-8') hash = hmac.new(word, word, hashlib.sha1).digest() return base64.b64encode(hash).decode("utf-8") print(string_to_hash('a')) #OQLthH/yiTC18UGr+otHFoElNnM= ================================================ FILE: Algorithms/FillNumbersInGivenRange.vb ================================================ Option Explicit Private currentMove As Direction Private size As Long Public Enum Direction Right Down Left Up End Enum Sub Main() Cells.Clear size = 2 SetMatrixStars MakeMatrix Cells.Columns.AutoFit End Sub Sub SetMatrixStars() Dim i As Long For i = 1 To size Cells(size + 1, i) = "*" Cells(i, size + 1) = "*" Next i Cells(size + 1, size + 1) = "*" End Sub Sub MakeMatrix() Dim currentCell As Range: Set currentCell = Cells(1, 1) currentMove = Right Dim i As Long Do While True i = i + 1 currentCell = i If IsLast(currentCell) Then Exit Do Set currentCell = nextCell(currentCell) Loop End Sub Function IsLast(currentCell As Range) As Boolean If size = 1 Then IsLast = True Exit Function End If If currentCell.Row = 1 Or currentCell.Column = 1 Then If size = 2 And currentCell = 4 Then IsLast = True Else IsLast = False End If Exit Function End If IsLast = Not IsEmpty(currentCell.Offset(1, 0)) _ And Not IsEmpty(currentCell.Offset(-1, 0)) _ And Not IsEmpty(currentCell.Offset(0, -1)) _ And Not IsEmpty(currentCell.Offset(0, 1)) End Function Public Function nextCell(currentCell As Range) As Range Select Case currentMove Case Direction.Right If IsEmpty(currentCell.Offset(, 1)) Then Set nextCell = currentCell.Offset(, 1) Else Set nextCell = currentCell.Offset(1) currentMove = Direction.Down End If Case Direction.Down If IsEmpty(currentCell.Offset(1)) Then Set nextCell = currentCell.Offset(1) Else Set nextCell = currentCell.Offset(, -1) currentMove = Direction.Left End If Case Direction.Left If currentCell.Column = 1 Then Set nextCell = currentCell.Offset(-1) currentMove = Direction.Up Else If IsEmpty(currentCell.Offset(, -1)) Then Set nextCell = currentCell.Offset(, -1) Else Set nextCell = currentCell.Offset(-1) currentMove = Direction.Up End If End If Case Direction.Up If IsEmpty(currentCell.Offset(-1)) Then Set nextCell = currentCell.Offset(-1) Else Set nextCell = currentCell.Offset(0, 1) currentMove = Direction.Right End If End Select End Function ================================================ FILE: Algorithms/Games/SnakeAttempt.vb ================================================ Option Explicit 'https://msdn.microsoft.com/en-us/library/windows/desktop/ms646299(v=vs.85).aspx 'https://msdn.microsoft.com/en-us/library/windows/desktop/ms646293(v=vs.85).aspx Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long Private Const SIZE_WIDTH As Long = 7 Private Const SIZE_HEIGTH As Long = 5 Private Const COL_WIDTH As Double = 2.3 Private Const BORDER_COL As Long = 190 Private wks As Worksheet Private pointX As Long Private pointY As Long Private leadPoint As Range Private pointField As Range Private movingDirection As Direction Public Enum Direction GoUp = 1 GoRight = 2 GoDown = 3 GoLeft = 4 End Enum Private Sub Main() FixThePitch InitializePoint PrintInformation MoveAround End Sub Public Sub PrintInformation() Debug.Print "Press Home to exit." End Sub Private Sub ShowNewFood() Dim positionRow As Long Dim positionCol As Long positionRow = 1 positionCol = 1 End Sub Private Function MakeRandom(down As Long, up As Long) As Long MakeRandom = CLng((up - down) * Rnd + down) End Function Public Sub ChangePoints(pointToChange As Long) pointField.value = pointField + pointToChange End Sub Public Sub GoMove(moveDir As Direction) Debug.Print moveDir End Sub Public Sub ColorSnake() With wks .Range(.Cells(1, 1), .Cells(SIZE_HEIGTH, SIZE_WIDTH)).Clear End With leadPoint.Interior.COLOR = vbWhite End Sub Private Sub MoveFurther() Select Case movingDirection Case GoUp: If leadPoint.row = 1 Then Set leadPoint = Cells(SIZE_HEIGTH, leadPoint.Column) Else Set leadPoint = Cells(leadPoint.row - 1, leadPoint.Column) End If Case GoRight: If leadPoint.Column = SIZE_WIDTH Then Set leadPoint = Cells(leadPoint.row, 1) Else Set leadPoint = Cells(leadPoint.row, leadPoint.Column + 1) End If Case GoDown: If leadPoint.row = SIZE_HEIGTH Then Set leadPoint = Cells(1, leadPoint.Column) Else Set leadPoint = Cells(leadPoint.row + 1, leadPoint.Column) End If Case GoLeft: If leadPoint.Column = 1 Then Set leadPoint = Cells(leadPoint.row, SIZE_WIDTH) Else Set leadPoint = Cells(leadPoint.row, leadPoint.Column - 1) End If End Select End Sub Private Sub ReadKey() Debug.Assert Not IsEmpty(GetAsyncKeyState(vbKeyUp)) Select Case True Case GetAsyncKeyState(vbKeyHome) Debug.Print "Exiting..." End Case GetAsyncKeyState(vbKeyUp): movingDirection = GoUp Case GetAsyncKeyState(vbKeyRight): movingDirection = GoRight Case GetAsyncKeyState(vbKeyDown): movingDirection = GoDown Case GetAsyncKeyState(vbKeyLeft): movingDirection = GoLeft End Select End Sub Private Sub MoveAround() movingDirection = Direction.GoRight Do While True DoEvents ReadKey ColorSnake MoveFurther Sleep (200) Loop End Sub Private Sub InitializePoint() Set leadPoint = wks.Cells(2, 3) End Sub Private Sub FixThePitch() Set wks = tbl_Internal1 wks.visible = xlSheetVisible wks.Activate With wks .Cells.Delete .Cells(1, 1).Select .Range(.Cells(1), .Cells(1 + SIZE_WIDTH)).ColumnWidth = COL_WIDTH .Range(.Cells(SIZE_HEIGTH + 1, 1), .Cells(SIZE_HEIGTH + 1, SIZE_WIDTH)).Borders.COLOR = RGB(BORDER_COL, BORDER_COL, BORDER_COL) .Range(.Cells(1, SIZE_WIDTH + 1), .Cells(SIZE_HEIGTH + 1, SIZE_WIDTH + 1)).Borders.COLOR = RGB(BORDER_COL, BORDER_COL, BORDER_COL) End With Set pointField = wks.Cells(8, 1) ChangePoints (0) End Sub ================================================ FILE: Algorithms/Games/SnakePrinting.vb ================================================ Option Explicit Public Function SnakeMyNumbers(n As Long) As String Dim lngCol As Long Dim lngRow As Long Dim str As String For lngCol = 0 To n - 1 str = "" For lngRow = 0 To n - 1 If lngRow Mod 2 = 0 Then str = str & vbTab & n * lngRow + lngCol + 1 Else str = str & vbTab & n * (lngRow + 1) - lngCol End If Next lngRow SnakeMyNumbers = SnakeMyNumbers & str & vbCrLf Next lngCol End Function ================================================ FILE: Algorithms/GoRightAndDown.vb ================================================ Option Explicit Sub GreedyAlgorithm() Dim rowsCount As Long Dim colCount As Long Dim l_row_counter As Long Dim l_col_counter As Long Dim l_min_value As Long Dim max_prev_cell As Long Dim arr_sum As Variant Dim arr_reverse As Variant Dim rng As Range Dim rng2 As Range Calculate Application.Calculation = xlCalculationManual Set rng = [matrix] Set rng2 = [matrix2] rowsCount = [matrix].Rows.Count colCount = [matrix].Columns.Count rng2.Clear l_min_value = Application.WorksheetFunction.Min([matrix]) - 1 ReDim arr_sum(rowsCount, colCount) ReDim arr_reverse(rowsCount, colCount) For l_row_counter = 1 To rowsCount For l_col_counter = 1 To colCount max_prev_cell = l_min_value If l_row_counter > 1 Then If arr_sum(l_row_counter - 1, l_col_counter) > max_prev_cell Then max_prev_cell = arr_sum(l_row_counter - 1, l_col_counter) End If End If If l_col_counter > 1 Then If arr_sum(l_row_counter, l_col_counter - 1) > max_prev_cell Then max_prev_cell = arr_sum(l_row_counter, l_col_counter - 1) End If End If arr_sum(l_row_counter, l_col_counter) = rng.Item(l_row_counter, l_col_counter) rng2.Item(l_row_counter, l_col_counter) = rng.Item(l_row_counter, l_col_counter) If max_prev_cell <> l_min_value Then arr_sum(l_row_counter, l_col_counter) = arr_sum(l_row_counter, l_col_counter) + max_prev_cell rng2.Item(l_row_counter, l_col_counter) = arr_sum(l_row_counter, l_col_counter) End If Next l_col_counter Next l_row_counter l_col_counter = l_col_counter - 1 l_row_counter = l_row_counter - 1 While (l_row_counter > 0) And (l_col_counter > 0) arr_reverse(l_row_counter, l_col_counter) = True If arr_sum(l_row_counter - 1, l_col_counter) > arr_sum(l_row_counter, l_col_counter - 1) Then l_row_counter = l_row_counter - 1 Else l_col_counter = l_col_counter - 1 End If Wend For l_row_counter = 1 To rowsCount For l_col_counter = 1 To colCount If arr_reverse(l_row_counter, l_col_counter) Then rng2.Item(l_row_counter, l_col_counter).Font.Color = vbRed End If Next l_col_counter Next l_row_counter rng.Columns.EntireColumn.AutoFit rng2.Columns.EntireColumn.AutoFit 'Application.Calculation = xlAutomatic End Sub ================================================ FILE: Algorithms/Knight.vb ================================================ Option Explicit Public r_range As Range Public r_used_range As Range Public l_result As Long Public Sub DeleteOthers() Dim r_cell As Range For Each r_cell In r_used_range If r_cell.Interior.Color <> vbGreen Then r_cell.ClearContents Next r_cell End Sub Public Sub CalculatePriceWithItalic(r_cell As Range, l_size As Long, Optional b_once As Boolean = False) Dim r_row As Range Dim r_col As Range Dim my_cell As Range Dim l_row As Long Dim l_col As Long l_result = 0 'RIGHT l_row = r_cell.Row + 1 l_col = r_cell.Column + 2 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) l_row = r_cell.Row - 1 l_col = r_cell.Column + 2 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) 'DOWN l_row = r_cell.Row + 2 l_col = r_cell.Column + 1 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) l_row = r_cell.Row + 2 l_col = r_cell.Column - 1 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) 'LEFT l_row = r_cell.Row - 1 l_col = r_cell.Column - 2 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) l_row = r_cell.Row + 1 l_col = r_cell.Column - 2 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) 'UP l_row = r_cell.Row - 2 l_col = r_cell.Column - 1 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) l_row = r_cell.Row - 2 l_col = r_cell.Column + 1 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) r_cell = l_result Set my_cell = Nothing End Sub Public Sub CheckRow(l_row As Long, l_col As Long, l_size As Long, r_cell As Range, b_once As Boolean) If l_row <= l_size And l_col <= l_size And l_row > 0 And l_col > 0 Then If Len(Cells(l_row, l_col)) < 1 And Cells(l_row, l_col).Address <> r_cell.Address Then l_result = l_result + 1 If b_once Then Call CalculatePriceWithItalic(Cells(l_row, l_col), l_size) End If End If End Sub Sub main() Dim my_array() As Variant Dim my_array_b() As Variant Dim l_counter As Long Dim l_counter_2 As Long Dim l_counter_moves As Long: l_counter_moves = 1 Dim my_cell As Range Dim b_animate As Boolean Dim l_starting_row As Long Dim l_starting_col As Long b_animate = True l_counter = 8 l_starting_row = 8 l_starting_col = 8 If l_starting_row > l_counter Or l_starting_row < 1 Then l_starting_row = l_counter If l_starting_col > l_counter Or l_starting_col < 1 Then l_starting_col = l_counter Call OnStart(b_animate) ReDim my_array(l_counter) Set r_used_range = Range(Cells(1, 1), Cells(100, 100)) r_used_range.Clear Set r_used_range = Range(Cells(1, 1), Cells(l_counter, l_counter)) r_used_range.Clear Call FormatRangeInitially(r_used_range) For l_counter_2 = 1 To l_counter ReDim my_array_b(l_counter) my_array(l_counter_2) = my_array_b Next l_counter_2 Set my_cell = Cells(l_starting_row, l_starting_col) While l_counter_moves <= (l_counter ^ 2) Call CalculatePriceWithItalic(my_cell, l_counter, True) Call FormatMyCell(my_cell, l_counter_moves, 1) If b_animate Then Application.Wait (Now + TimeValue("00:00:01")) Call FormatMyCell(my_cell, l_counter_moves, 2) l_counter_moves = l_counter_moves + 1 Set my_cell = FindNextTarget Call DeleteOthers Wend Set r_used_range = Nothing Set r_range = Nothing Set my_cell = Nothing Call OnEnd End Sub Function FindNextTarget() As Range Dim my_next As Range Dim lowest As Long: lowest = 9999 For Each my_next In r_used_range If my_next.Value < lowest And my_next.Value > 0 And my_next.Interior.Color <> vbGreen Then lowest = my_next.Value Set FindNextTarget = my_next End If Next my_next End Function Sub FormatMyCell(ByRef my_cell_range As Range, l_counter As Long, l_color As Long) If l_color = 2 Then my_cell_range.Interior.Color = vbGreen If l_color = 1 Then my_cell_range.Interior.Color = vbRed my_cell_range = l_counter End Sub Public Sub FormatRangeInitially(r_range As Range) r_range.HorizontalAlignment = xlCenter r_range.Borders(xlDiagonalDown).LineStyle = xlNone r_range.Borders(xlDiagonalUp).LineStyle = xlNone With r_range.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With r_range.ColumnWidth = 3.2 End Sub Public Sub OnStart(b_animate As Boolean) Application.DisplayAlerts = False If Not b_animate Then Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False End Sub Public Sub OnEnd() 'Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False End Sub ================================================ FILE: Algorithms/LongestIncreasingSubsequence.vb ================================================ Option Explicit Public Const NO_PREVIOUS = -1 Sub Main() Dim arrSeq As Variant Dim arrLen As Variant Dim arrPre As Variant Dim bestLength As Long arrSeq = Array(1, 2, -6, -5, -3, 23, 123, 3, 2, -23, -5, 54, 100, 200, 300, 1111, 23412, 3, 4, 5, 6, 7, 8, 9, 19, 65, 2) ReDim arrLen(UBound(arrSeq)) ReDim arrPre(UBound(arrSeq)) bestLength = CalculateLongestIncreasingSubsequence(arrSeq, arrLen, arrPre) PrintArray arrSeq PrintArray arrLen PrintArray arrPre PrintLongestIncreasingSubsequance arrSeq, arrPre, bestLength End Sub Public Sub PrintLongestIncreasingSubsequance(ByRef arrSeq As Variant, _ ByRef arrPre As Variant, _ bestLength As Long) Dim arrResult As Variant Dim counter As Long: counter = 0 ReDim arrResult(1) While (bestLength <> NO_PREVIOUS) ReDim Preserve arrResult(counter) counter = counter + 1 arrResult(counter - 1) = arrSeq(bestLength) bestLength = arrPre(bestLength) Wend Debug.Print Join(ReverseArray(arrResult), " ") End Sub Public Function CalculateLongestIncreasingSubsequence(ByRef arrSeq As Variant, _ ByRef arrLen As Variant, _ ByRef arrPre As Variant) As Long Dim bestLengthLen As Long: bestLengthLen = 0 Dim bestLengthIndex As Long: bestLengthIndex = 0 Dim x As Long Dim i As Long For x = LBound(arrSeq) To (UBound(arrSeq)) arrLen(x) = 1 arrPre(x) = NO_PREVIOUS For i = 0 To x Step 1 If (arrSeq(i) < arrSeq(x)) And (arrLen(i) + 1 > arrLen(x)) Then arrLen(x) = arrLen(i) + 1 arrPre(x) = i If arrLen(x) > bestLengthLen Then bestLengthLen = arrLen(x) bestLengthIndex = x End If End If Next i Next x CalculateLongestIncreasingSubsequence = bestLengthIndex End Function Public Sub PrintArray(ByRef myArray As Variant) Dim counter As Long For counter = LBound(myArray) To UBound(myArray) Debug.Print counter & " --> " & myArray(counter) Next counter Debug.Print "------------------------------" End Sub Public Function ReverseArray(ByVal myArray As Variant) As Variant Dim counter As Long Dim counter2 As Long Dim arrNew As Variant ReDim arrNew(UBound(myArray) + 1) For counter = LBound(arrNew) To UBound(arrNew) - 1 counter2 = UBound(arrNew) - counter - 1 arrNew(counter) = myArray(counter2) Next counter ReverseArray = arrNew End Function ================================================ FILE: Algorithms/NpComplete/NestedLoops.vb ================================================ Option Explicit Sub TestMe() Dim myArr As Variant Dim myLoop As Variant Dim targetValue As Long Dim currentSum As Long myArr = Array(215, 275, 335, 355, 420, 580) targetValue = 1505 Dim cnt0&, cnt1&, cnt2&, cnt3&, cnt4&, cnt5&, cnt6& Dim cnt As Long For cnt0 = 0 To 5 For cnt1 = 0 To 5 For cnt2 = 0 To 5 For cnt3 = 0 To 5 For cnt4 = 0 To 5 For cnt5 = 0 To 5 currentSum = 0 Dim printableArray As Variant printableArray = Array(cnt0, cnt1, cnt2, cnt3, cnt4, cnt5) For cnt = LBound(myArr) To UBound(myArr) IncrementSum printableArray(cnt), myArr(cnt), currentSum Next cnt If currentSum = targetValue Then printValuesOfArray printableArray, myArr End If Next: Next: Next: Next: Next: Next End Sub Public Sub printValuesOfArray(myArr As Variant, initialArr As Variant) Dim cnt As Long Dim printVal As String For cnt = LBound(myArr) To UBound(myArr) If myArr(cnt) Then printVal = printVal & myArr(cnt) & " * " & initialArr(cnt) & vbCrLf End If Next cnt Debug.Print printVal End Sub Public Sub IncrementSum(ByVal multiplicator As Long, _ ByVal arrVal As Long, ByRef currentSum As Long) currentSum = currentSum + arrVal * multiplicator End Sub ================================================ FILE: Algorithms/NpComplete/RecursionLoops.vb ================================================ Option Explicit Sub Main() Dim posArr As Variant Dim iniArr As Variant Dim tryArr As Variant Dim cnt As Long Dim targetVal As Long: targetVal = 1505 iniArr = Array(215, 275, 335, 355, 420, 580) ReDim posArr(UBound(iniArr)) ReDim tryArr(UBound(iniArr)) For cnt = LBound(posArr) To UBound(posArr) posArr(cnt) = cnt Next cnt EmbeddedLoops 0, posArr, tryArr, iniArr, targetVal End Sub Function EmbeddedLoops(index As Long, posArr As Variant, tryArr As Variant, _ iniArr As Variant, targetVal As Long) Dim myUnit As Variant Dim cnt As Long If index >= UBound(posArr) + 1 Then If CheckSum(tryArr, iniArr, targetVal) Then For cnt = LBound(tryArr) To UBound(tryArr) If tryArr(cnt) Then Debug.Print tryArr(cnt) & " x " & iniArr(cnt) Next cnt End If Else For Each myUnit In posArr tryArr(index) = myUnit EmbeddedLoops index + 1, posArr, tryArr, iniArr, targetVal Next myUnit End If End Function Public Function CheckSum(posArr, iniArr, targetVal) As Boolean Dim cnt As Long Dim compareVal As Long For cnt = LBound(posArr) To UBound(posArr) compareVal = posArr(cnt) * iniArr(cnt) + compareVal Next cnt CheckSum = CBool(compareVal = targetVal) End Function ================================================ FILE: Algorithms/NpComplete/readme.md ================================================ Both VBA files are a solution of this joke: ![alt text](https://imgs.xkcd.com/comics/np_complete.png) ================================================ FILE: Algorithms/PwdHacks/CrackerJack.vb ================================================ '--------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------- Option Explicit Public Sub CJ() If CJ.Hook Then Debug.Print "The deal is done!" End If End Sub '--------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------- Option Explicit Option Private Module Private Const PAGE_EXECUTE_READWRITE = &H40 Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _ (Destination As Long, Source As Long, ByVal Length As Long) Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _ ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _ ByVal lpProcName As String) As Long Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _ ByVal pTemplateName As Long, ByVal hWndParent As Long, _ ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer Dim HookBytes(0 To 5) As Byte Dim OriginBytes(0 To 5) As Byte Dim pFunc As Long Dim Flag As Boolean Private Function GetPtr(ByVal Value As Long) As Long GetPtr = Value End Function Public Sub RecoverBytes() If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6 End Sub Public Function Hook() As Boolean Dim TmpBytes(0 To 5) As Byte Dim p As Long Dim OriginProtect As Long Hook = False pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA") If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6 If TmpBytes(0) <> &H68 Then MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6 p = GetPtr(AddressOf MyDialogBoxParam) HookBytes(0) = &H68 MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4 HookBytes(5) = &HC3 MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6 Flag = True Hook = True End If End If End Function Private Function MyDialogBoxParam(ByVal hInstance As Long, _ ByVal pTemplateName As Long, ByVal hWndParent As Long, _ ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer If pTemplateName = 4070 Then MyDialogBoxParam = 1 Else RecoverBytes MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _ hWndParent, lpDialogFunc, dwInitParam) Hook End If End Function '--------------------- '--------------------- '--------------------- '--------------64 bits Option Explicit Private Const PAGE_EXECUTE_READWRITE = &H40 Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _ (Destination As LongPtr, Source As LongPtr, ByVal Length As LongPtr) Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (lpAddress As LongPtr, _ ByVal dwSize As LongPtr, ByVal flNewProtect As LongPtr, lpflOldProtect As LongPtr) As LongPtr Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, _ ByVal lpProcName As String) As LongPtr Private Declare PtrSafe Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As LongPtr, _ ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _ ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer Dim HookBytes(0 To 5) As Byte Dim OriginBytes(0 To 5) As Byte Dim pFunc As LongPtr Dim Flag As Boolean Private Function GetPtr(ByVal Value As LongPtr) As LongPtr GetPtr = Value End Function Public Sub RecoverBytes() If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6 End Sub Public Function Hook() As Boolean Dim TmpBytes(0 To 5) As Byte Dim p As LongPtr Dim OriginProtect As LongPtr Hook = False pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA") If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6 If TmpBytes(0) <> &H68 Then MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6 p = GetPtr(AddressOf MyDialogBoxParam) HookBytes(0) = &H68 MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4 HookBytes(5) = &HC3 MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6 Flag = True Hook = True End If End If End Function Private Function MyDialogBoxParam(ByVal hInstance As LongPtr, _ ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _ ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer If pTemplateName = 4070 Then MyDialogBoxParam = 1 Else RecoverBytes MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _ hWndParent, lpDialogFunc, dwInitParam) Hook End If End Function ================================================ FILE: Algorithms/PwdHacks/GhostBreakInfo.vb ================================================ 'http://stackoverflow.com/questions/2154699/excel-vba-app-stops-spontaneously-with-message-code-execution-has-been-halted 'Ghost break unwanted break freezing Press "Debug" button in the popup. Press Ctrl+Pause|Break twice. Hit the play button to continue. Save the file after completion. ================================================ FILE: Algorithms/PwdHacks/Xlsb.PasswordRemover.vb ================================================ Change .xlsb to .zip Open zip xl>vbaProject.bin Search and replace "DPB" with "DPx", where there is a string after Save all Change back .zip to .xlsb Open and click "Yes" ================================================ FILE: Algorithms/QueenDrama.vb ================================================ Option Explicit Public Const SIZE = 8 Public b_chessboard(7, 7) As Variant Public l_solutions_found As Long Public attackedRows As Object ' as New Scripting.Dictionary => for early binding with Microsoft Scripting Runtime Public attackedColumns As Object Public attackedLeftDiagonals As Object Public attackedRightDiagonals As Object Sub Main() Set attackedRows = CreateObject("Scripting.Dictionary") Set attackedColumns = CreateObject("Scripting.Dictionary") Set attackedLeftDiagonals = CreateObject("Scripting.Dictionary") Set attackedRightDiagonals = CreateObject("Scripting.Dictionary") tbl_show.Cells.Delete l_solutions_found = 0 Call PutQueens(0) tbl_show.Columns.ColumnWidth = 3 Set attackedRows = Nothing Set attackedColumns = Nothing Set attackedLeftDiagonals = Nothing Set attackedRightDiagonals = Nothing End Sub Sub PutQueens(l_row As Long) Dim l_col As Long If l_row = SIZE Then Call PrintSolution l_solutions_found = l_solutions_found + 1 Else For l_col = 0 To SIZE - 1 Step 1 If CanPlaceQueen(l_row, l_col) Then Call MarkAllAttackedPositions(l_row, l_col) Call PutQueens(l_row + 1) Call UnmarkAllattackedPositions(l_row, l_col) End If Next l_col End If End Sub Public Function CanPlaceQueen(l_row As Long, l_col As Long) As Boolean Dim b_result As Boolean b_result = dictionary_contains(attackedRows, l_row) Or _ dictionary_contains(attackedColumns, l_col) Or _ dictionary_contains(attackedLeftDiagonals, l_col - l_row) Or _ dictionary_contains(attackedRightDiagonals, l_col + l_row) CanPlaceQueen = Not b_result End Function Public Sub PrintSolution() Dim l_row As Long Dim l_col As Long Dim l_row_fixer As Long Dim l_col_fixer As Long Dim s_result As String l_row_fixer = (l_solutions_found \ 9) * 9 + 1 l_col_fixer = (l_solutions_found Mod 9) * 9 + 1 For l_row = 0 To SIZE - 1 Step 1 For l_col = 0 To SIZE - 1 Step 1 If b_chessboard(l_row, l_col) Then s_result = s_result & "*" tbl_show.Cells(l_row + l_row_fixer, l_col + l_col_fixer).Interior.Color = vbRed Else s_result = s_result & "-" tbl_show.Cells(l_row + l_row_fixer, l_col + l_col_fixer).Interior.Color = vbBlue End If Next l_col s_result = s_result & vbCrLf Next l_row Debug.Print l_solutions_found & vbCrLf & s_result End Sub Public Sub MarkAllAttackedPositions(l_row As Long, l_col As Long) attackedRows(l_row) = False attackedColumns(l_col) = False attackedLeftDiagonals(l_col - l_row) = False attackedRightDiagonals(l_col + l_row) = False b_chessboard(l_row, l_col) = True End Sub Public Sub UnmarkAllattackedPositions(l_row As Long, l_col As Long) attackedRows.Remove (l_row) attackedColumns.Remove (l_col) attackedLeftDiagonals.Remove (l_col - l_row) attackedRightDiagonals.Remove (l_col + l_row) b_chessboard(l_row, l_col) = False End Sub Public Function dictionary_contains(dict As Object, str_element As Variant) As Boolean Dim item As Variant Dim b_result As Boolean For Each item In dict If item = str_element Then b_result = True Next item dictionary_contains = b_result End Function Public Sub TestDictionary() attackedRows("a") = 1 attackedRows("b") = 2 attackedRows(15) = 3 Debug.Print dictionary_contains(attackedRows, "b") Debug.Print dictionary_contains(attackedRows, "a") Debug.Print dictionary_contains(attackedRows, "d") Debug.Print dictionary_contains(attackedRows, "d") Debug.Print dictionary_contains(attackedRows, 15) Debug.Print "REMOVE" attackedRows.Remove ("a") Debug.Print dictionary_contains(attackedRows, "a") Debug.Print dictionary_contains(attackedRows, "a") End Sub ================================================ FILE: Algorithms/StringManipulations.vb ================================================ Function Insert(original As String, added As String, pos As Long) As String If pos < 1 Then pos = 1 If Len(original) < pos Then pos = Len(original) + 1 Insert = Mid(original, 1, pos - 1) _ & added _ & Mid(original, pos, Len(original) - pos + 1) End Function Public Sub InsertTests() Debug.Print Insert("abcd", "ff", 0) = "ffabcd" Debug.Print Insert("abcd", "ff", 1) = "ffabcd" Debug.Print Insert("abcd", "ff", 2) = "affbcd" Debug.Print Insert("abcd", "ff", 3) = "abffcd" Debug.Print Insert("abcd", "ff", 4) = "abcffd" Debug.Print Insert("abcd", "ff", 100) = "abcdff" End Sub Public Function StringRepeater(repeatString As String, count As Long) As String 'StringBuilder String Builder If count < 1 Or Len(repeatString) < 1 Then Exit Function Dim cnt As Long For cnt = 1 To count StringRepeater = StringRepeater & repeatString Next cnt End Function Public Sub StringRepeaterTests() Debug.Print StringRepeater("ab", 3) = "ababab" Debug.Print StringRepeater("a", 2) = "aa" End Sub ================================================ FILE: Algorithms/TaxiCabNumbers.vb ================================================ 'https://en.wikipedia.org/wiki/Taxicab_number Option Explicit Public Sub TaxiCabNumber() Dim a As Long Dim b As Long Dim lastNumber As Long Dim cnt As Long lastNumber = 200 Dim arrList As Object Set arrList = CreateObject("System.Collections.ArrayList") For a = 1 To lastNumber For b = a + 1 To lastNumber Dim current As String current = a ^ 3 + b ^ 3 'Debug.Assert (a <> 1 Or b <> 12) And (a <> 9 Or b <> 10) If arrList.contains(current) Then Debug.Print current Else arrList.Add (current) End If cnt = cnt + 1 Next b Next a End Sub ================================================ FILE: Algorithms/TraverseGraph.vb ================================================ 'Exercises: graph Algorithms 'This document defines the in-class exercises assignments for the "Algorithms" course @ Software University. 'For the following exercises you are given a Visual Studio solution "Graph-Algorithms-Lab" holding portions of the source code + unit tests. You can download it from the course's page. 'Part I - Traverse a Graph to Find Its Connected Components Option Explicit Public visited As Variant Public graph As Variant Public Sub mains() Dim l_counter As Long Dim g1 As Variant Dim g2 As Variant Dim g3 As Variant Dim g4 As Variant Dim g5 As Variant Dim g6 As Variant Dim g7 As Variant Dim g8 As Variant Dim g9 As Variant g1 = Array(3, 6) g2 = Array(3, 4, 5, 6) g3 = Array(8) g4 = Array(0, 1, 5) g5 = Array(1, 6) g6 = Array(1, 3) g7 = Array(0, 1, 4) g8 = Array() g9 = Array(2) graph = Array(g1, g2, g3, g4, g5, g6, g7, g8, g9) ReDim visited(0) For l_counter = LBound(graph) To UBound(graph) If UBound(graph(l_counter)) >= 0 Then If Not b_value_in_array(graph(l_counter)(0), visited) Then Call DFS(graph(l_counter)(0)) Debug.Print "---------------------" End If Else Debug.Print l_counter Debug.Print "---------------------" End If Next l_counter End Sub Public Sub DFS(ByVal str_node As String) Dim nodes As Variant Dim cur_node As String Dim child_node As Variant Dim k As Variant nodes = Array(0, str_node) ReDim Preserve visited(UBound(visited) + 1) visited(UBound(visited)) = str_node While UBound(nodes) > 0 cur_node = nodes(UBound(nodes)) Debug.Print cur_node ReDim Preserve nodes(UBound(nodes) - 1) child_node = graph(cur_node) For Each k In child_node If Not b_value_in_array(k, visited) Then ReDim Preserve nodes(UBound(nodes) + 1) nodes(UBound(nodes)) = k ReDim Preserve visited(UBound(visited) + 1) visited(UBound(visited)) = k End If Next k Wend End Sub Public Function b_value_in_array(my_value As Variant, my_array As Variant, Optional b_is_string As Boolean = False) As Boolean Dim l_counter As Long If b_is_string Then my_array = Split(my_array, ":") End If For l_counter = LBound(my_array) To UBound(my_array) my_array(l_counter) = CStr(my_array(l_counter)) Next l_counter b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0)) End Function ================================================ FILE: Boilerplate/ApplicationOnKey.vb ================================================ 'https://msdn.microsoft.com/en-us/library/office/ff197461.aspx Public Sub EnableControls() Application.OnKey "^{F8}", "F8_CtrlMacro" Application.OnKey "%{F8}", "F8_AltMacro" Application.OnKey "+{F8}", "F8_ShiftMacro" Application.OnKey "{F8}", "F8_OnlyMacro" End Sub Public Sub DisableControls() Application.OnKey "^{F8}", "" Application.OnKey "%{F8}", "" Application.OnKey "+{F8}", "" Application.OnKey "{F8}", "" End Sub Public Sub F8_CtrlMacro() Debug.Print "F8 with Ctrl" End Sub Public Sub F8_AltMacro() Debug.Print "F8 with Alt" End Sub Public Sub F8_ShiftMacro() Debug.Print "F8 with Shift" End Sub Public Sub F8_OnlyMacro() Debug.Print "F8 Only" End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/ConstantsAndPublic.bas ================================================ Attribute VB_Name = "ConstantsAndPublic" Option Explicit Option Private Module Public Const SET_IN_PRODUCTION = True Public Const WORKSHEET_UNPROTECT_PASSWORD = "shouldistayorshouldigo" 'I am never using this password anywhere, do not bother ;) Public Const ADMINS = "vitosh:vitos" Public Const CON_STR_APP_NAME = "Boilerplate VitoshAcademy" Public Const CON_STR_INSTANCES_LOG = "More then one Workbook is opened in this Excel instance." Public Const CON_STR_1904 = "You are using 1904 date system. This is probably* not what you need." 'Public variables are a bad practice and should be avoided in general... Public PUB_STR_ERROR_REPORT As String ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/ExcelAdditional.bas ================================================ Attribute VB_Name = "ExcelAdditional" Option Explicit Option Private Module Public Sub FreezeRow(Optional wsName As String = "Input", Optional cellAddress As String = "B5") Dim ws As Worksheet Set ws = Worksheets(wsName) ActiveWindow.FreezePanes = False Application.Goto ws.Range(cellAddress) ActiveWindow.FreezePanes = True End Sub Public Sub UnfreezeRows(Optional wsName As String = "Input") Dim ws As Worksheet Set ws = Worksheets(wsName) ActiveWindow.FreezePanes = False End Sub Public Function SumArray(myArray As Variant, Optional lastValuesNotToCalculate As Long = 0) As Double Dim i As Long For i = LBound(myArray) To UBound(myArray) - lastValuesNotToCalculate SumArray = SumArray + myArray(i) Next End Function Public Function ChangeCommas(ByVal myValue As Variant) As String Dim temp As String temp = CStr(myValue) ChangeCommas = Replace(temp, ",", ".") End Function Public Function BubbleSort(ByRef myArray As Variant) As Variant Dim temp As Variant Dim i As Long Dim noExchanges As Boolean Do noExchanges = True For i = LBound(myArray) To UBound(myArray) - 1 If CDbl(myArray(i)) > CDbl(myArray(i + 1)) Then noExchanges = False temp = myArray(i) myArray(i) = myArray(i + 1) myArray(i + 1) = temp End If Next i Loop While Not (noExchanges) BubbleSort = myArray On Error GoTo 0 Exit Function End Function Public Function IsArrayAllocated(varArr As Variant) As Boolean On Error Resume Next IsArrayAllocated = IsArray(varArr) And Not IsError(LBound(varArr, 1)) And LBound(varArr, 1) <= UBound(varArr, 1) On Error GoTo 0 End Function Public Function RangeIsZeroOrEmpty(myRange As Range) As Boolean Dim myCell As Range If myRange.Cells.Count > 1 Then For Each myCell In myRange If (isEmpty(myCell) Or myCell.value = 0) Then RangeIsZeroOrEmpty = True Else RangeIsZeroOrEmpty = False Exit Function End If Next myCell Else If (isEmpty(myRange) Or myRange.value = 0) Then RangeIsZeroOrEmpty = True Else RangeIsZeroOrEmpty = False End If End If End Function Public Function MakeRandom(lowest As Long, highest As Long) As Long 'WorksheetFunction.randbetween for outside Excel MakeRandom = CLng((highest - lowest) * Rnd + lowest) End Function Public Function IsRangeHidden(myRange As Range) As Boolean If myRange.EntireRow.Hidden Or myRange.EntireColumn.Hidden Then IsRangeHidden = True End If End Function Public Function ColumnNumberToLetter(col As Long) As String ColumnNumberToLetter = Split(Cells(1, col).Address, "$")(1) End Function Public Function IsValueInArray(varMyValue As Variant, myArray As Variant, _ Optional isValueString As Boolean = False) As Boolean Dim i As Long If isValueString Then myArray = Split(myArray, ":") End If For i = LBound(myArray) To UBound(myArray) myArray(i) = CStr(myArray(i)) Next i IsValueInArray = Not IsError(Application.Match(CStr(varMyValue), myArray, 0)) End Function Public Function Rgb2HtmlColor(r As Byte, g As Byte, b As Byte) As String 'INPUT: Numeric (Base 10) Values for R, G, and B) 'RETURNS: 'A string that can be used as an HTML Color '(i.e., "#" + the Hexadecimal equivalent) 'For VBA the RGB is reversed. R and B are revered... Dim varHexR As Variant Dim varHexB As Variant Dim varHexG As Variant 'R varHexR = Hex(r) If Len(varHexR) < 2 Then varHexR = "0" & varHexR 'Get Green Hex varHexG = Hex(g) If Len(varHexG) < 2 Then varHexG = "0" & varHexG varHexB = Hex(b) If Len(varHexB) < 2 Then varHexB = "0" & varHexB Rgb2HtmlColor = "#" & varHexR & varHexG & varHexB End Function Function NamedRangeExists(rangeName As String) As Boolean On Error Resume Next Dim myRange As Range Set myRange = Range(rangeName) If Not myRange Is Nothing Then NamedRangeExists = True On Error GoTo 0 End Function Function GetRgb(lngLong) As String Dim r As Long Dim g As Long Dim b As Long r = lngLong Mod 256 g = lngLong \ 256 Mod 256 b = lngLong \ 65536 Mod 256 GetRgb = "R=" & r & ", G=" & g & ", B=" & b End Function Public Sub CopyValues(mySource As Range, myTarget As Range) myTarget.Resize(mySource.Rows.Count, mySource.Columns.Count).value = mySource.value End Sub Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.AskToUpdateLinks = True Application.DisplayAlerts = True ActiveWindow.View = xlNormalView Application.StatusBar = False Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False End Sub Public Sub OnStart() Application.ScreenUpdating = False Application.EnableEvents = False Application.AskToUpdateLinks = False Application.DisplayAlerts = False ActiveWindow.View = xlNormalView Application.StatusBar = False Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/ExcelDates.bas ================================================ Attribute VB_Name = "ExcelDates" Option Explicit Option Private Module Public Function GetLastDayOfMonth(ByVal myDate As Date) As Date GetLastDayOfMonth = DateSerial(Year(myDate), Month(myDate) + 1, 0) End Function Public Function GetFirstDayOfMonth(ByVal myDate As Date) As Date GetFirstDayOfMonth = DateSerial(Year(myDate), Month(myDate), 1) End Function Public Function AddMonths(ByVal myDate As Date, ByVal lngMonth As Long) As Date AddMonths = GetLastDayOfMonth(DateAdd("m", lngMonth, myDate)) End Function Public Function AddMonthsAndGetFirstDate(ByVal my_date As Date, ByVal lngMonth As Long) As Date AddMonthsAndGetFirstDate = GetFirstDayOfMonth(DateAdd("m", lngMonth, my_date)) End Function Public Function DateDiffInMonths(a As Date, b As Date) As Long DateDiffInMonths = DateDiff("m", a, b) End Function ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/ExcelFormatCell.bas ================================================ Attribute VB_Name = "ExcelFormatCell" Option Explicit Option Private Module Public Sub FormatAsDate(myCell As Range) myCell.NumberFormat = "[$-407]mmm/ yy;@" End Sub Public Sub FormatAsPercent(myCell As Range, Optional afterComma = 2) If afterComma = 3 Then myCell.NumberFormat = "0.000%" Else myCell.NumberFormat = "0.00%" End If End Sub Public Sub FormatAsCurrency(myCell As Range, _ Optional changeZero = False, _ Optional makeGray = True, _ Optional makeRound = True) Dim isOneCell As Boolean isOneCell = IIf(myCell.Rows.Count + myCell.Columns.Count <> 2, False, True) If IsNumeric(myCell.value) And (Not myCell.HasFormula) Then myCell.value = Round(myCell.value, 2) End If If makeRound Then myCell.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" Else myCell.NumberFormat = "$#,##0.00_);($#,##0.00)" End If If changeZero Then With myCell .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=0" .FormatConditions(1).Font.ThemeColor = xlThemeColorDark1 .FormatConditions(1).Font.TintAndShade = -0.4 End With End If If isOneCell Then If makeGray And myCell.value = 0 Then With myCell .Cells.Font.Color = RGB(191, 191, 191) End With End If End If End Sub Public Sub FormatAsEurProM2(myCell As Range) myCell.NumberFormat = "#,##0.00 "" / m""" End Sub Public Sub FormatRedAndBold(myCell As Range, Optional isBold = True) myCell.Font.Color = -16777063 myCell.Font.TintAndShade = 0 If isBold Then myCell.Font.Bold = True End Sub Public Sub WhiteRows(lines As Long, wks As Worksheet) Dim rowLines As String rowLines = lines & ":" & lines With wks.Rows(rowLines).Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End Sub Public Sub WhiteCell(myCell As Range) myCell.Font.ThemeColor = xlThemeColorDark1 myCell.Font.TintAndShade = 0 End Sub Public Sub FormatFontColorToGrey(myCell As Range) myCell.Font.Color = RGB(128, 128, 128) End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/ExcelLastThings.bas ================================================ Attribute VB_Name = "ExcelLastThings" Option Explicit Option Private Module Public Function LastColumn(wsName As String, Optional rowToCheck As Long = 1) As Long Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets(wsName) LastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column End Function Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets(wsName) LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row End Function Public Function LastUsedColumn(wsName As String) As Long Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets(wsName) Dim lastCell As Range Set lastCell = ActiveSheet.Cells.Find(What:="*", _ After:=ActiveSheet.Cells(1, 1), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False) LastUsedColumn = lastCell.Column End Function Public Function LastUsedRow(wsName As String) As Long Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets(wsName) Dim lastCell As Range Set lastCell = ActiveSheet.Cells.Find(What:="*", _ After:=ActiveSheet.Cells(1, 1), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False) LastUsedRow = lastCell.Row End Function Public Function LocateValueRow(ByVal textTarget As String, _ ByRef wksTarget As Worksheet, _ Optional col As Long = 1, _ Optional moreValuesFound As Long = 1, _ Optional lookForPart = False, _ Optional lookUpToBottom = True) As Long Dim valuesFound As Long Dim localRange As Range Dim myCell As Range LocateValueRow = -999 valuesFound = moreValuesFound Set localRange = wksTarget.Range(wksTarget.Cells(1, col), wksTarget.Cells(Rows.Count, col)) For Each myCell In localRange If lookForPart Then If textTarget = Left(myCell, Len(textTarget)) Then If valuesFound = 1 Then LocateValueRow = myCell.Row If lookUpToBottom Then Exit Function Else Decrement valuesFound End If End If Else If textTarget = Trim(myCell) Then If valuesFound = 1 Then LocateValueRow = myCell.Row If lookUpToBottom Then Exit Function Else Decrement valuesFound End If End If End If Next myCell End Function Public Function LocateValueCol(ByVal textTarget As String, _ ByRef wksTarget As Worksheet, _ Optional rowNeeded As Long = 1, _ Optional moreValuesFound As Long = 1, _ Optional lookForPart = False, _ Optional lookUpToBottom = True) As Long Dim valuesFound As Long Dim localRange As Range Dim myCell As Range LocateValueCol = -999 valuesFound = moreValuesFound Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.Count)) For Each myCell In localRange If lookForPart Then If textTarget = Left(myCell, Len(textTarget)) Then If valuesFound = 1 Then LocateValueCol = myCell.Column If lookUpToBottom Then Exit Function Else Decrement valuesFound End If End If Else If textTarget = Trim(myCell) Then If valuesFound = 1 Then LocateValueCol = myCell.Column If lookUpToBottom Then Exit Function Else Decrement valuesFound End If End If End If Next myCell End Function Public Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1) valueToIncrement = valueToIncrement + incrementWith End Sub Public Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1) valueToDecrement = valueToDecrement - decrementWith End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/ExcelPrintToNotepad.bas ================================================ Attribute VB_Name = "ExcelPrintToNotepad" Option Explicit Option Private Module Sub PrintToNotepad(Optional dataToPrint As String = "") If SET_IN_PRODUCTION Then On Error GoTo CreateLogFile_Error Dim fileSystem As Object Dim textObject As Object Dim fileName As String Dim newFile As String Dim shellPath As String newFile = "\Info" fileName = ThisWorkbook.path & newFile & CodifyTime(True) If Dir(ThisWorkbook.path & newFile, vbDirectory) = vbNullString Then MkDir ThisWorkbook.path & newFile Set fileSystem = CreateObject("Scripting.FileSystemObject") Set textObject = fileSystem.CreateTextFile(fileName, True) If dataToPrint <> "" Then textObject.WriteLine dataToPrint Else textObject.WriteLine PUB_STR_ERROR_REPORT End If textObject.Close shellPath = "C:\WINDOWS\notepad.exe " shellPath = shellPath & fileName shell shellPath On Error GoTo 0 Exit Sub CreateLogFile_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CreateLogFile of Sub mod_TDD_Export" End Sub Public Function CodifyTime(Optional makeString As Boolean = False) As String If SET_IN_PRODUCTION Then On Error GoTo codify_Error Dim leftPart As Variant Dim rightPart As Variant Dim initialTime As Double initialTime = Round(Now(), 8) leftPart = Split(CStr(initialTime), ".")(0) rightPart = Split(CStr(initialTime), ".")(1) CodifyTime = Hex(leftPart) & "_" & Hex(rightPart) If makeString Then CodifyTime = "\" & CodifyTime & ".txt" On Error GoTo 0 Exit Function codify_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure codify of Function TDD_Export" End Function Public Function DecodifyTime(hexTime As String) As String Dim leftPart As Variant Dim rightPart As Variant leftPart = Split(hexTime, "_")(0) rightPart = Split(hexTime, "_")(1) DecodifyTime = CLng("&H" & leftPart) & "." & CLng("&H" & rightPart) End Function ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/ExcelStructure.bas ================================================ Attribute VB_Name = "ExcelStructure" Option Explicit Option Private Module Public Sub LockScroll(lockArea As Range) Dim wks As Worksheet For Each wks In ThisWorkbook.Worksheets wks.ScrollArea = lockArea.Address Next wks End Sub Public Sub UnlockScroll() Dim wks As Worksheet For Each wks In ThisWorkbook.Worksheets wks.ScrollArea = "" Next wks End Sub Sub StyleKiller() Dim myStyle As Style For Each myStyle In ThisWorkbook.Styles If Not myStyle.BuiltIn Then Debug.Print myStyle.Name myStyle.Delete End If Next End Sub Public Sub DeleteName(myName As String) On Error GoTo DeleteName_Error ThisWorkbook.Names(myName).Delete Debug.Print myName & " is deleted!" On Error GoTo 0 Exit Sub DeleteName_Error: Debug.Print myName & " not present or some error" On Error GoTo 0 End Sub Sub CoverRange(myRange As Range, wks As Worksheet) Dim myLeft As Long Dim myTop As Long Dim myWidth As Long Dim myHeight As Long If wks.Name <> ActiveSheet.Name Then MsgBox "You better select the sheet you are working on..." Exit Sub End If myLeft = myRange.Left myTop = myRange.Top myWidth = myRange.Width myHeight = myRange.Height With wks.Shapes .AddTextbox(msoTextOrientationVertical, myLeft, myTop, myWidth, myHeight).Select Selection.ShapeRange.Line.Visible = msoFalse End With End Sub Public Sub PrintSheetPDF(inputPrintArea As Range, _ printedFileName As String, _ Optional isBlack As Boolean = False) If SET_IN_PRODUCTION Then On Error GoTo PrintPDF_Error Dim wks As Worksheet Set wks = Worksheets(inputPrintArea.Parent.Name) With wks .PageSetup.Zoom = False .PageSetup.BlackAndWhite = isBlack inputPrintArea.ExportAsFixedFormat _ Type:=xlTypePDF, _ fileName:=printedFileName, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=True End With On Error GoTo 0 Exit Sub PrintPDF_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PrintPDF of Modul mod_Drucken" End Sub Public Sub PrintPage(printRange As Range, Optional isBlack As Boolean = False) Dim wksSheet As Worksheet Dim reducePaperTitle As String On Error GoTo PrintPage_Error reducePaperTitle = "Reduce printing and save trees!" printRange.Parent.PageSetup.BlackAndWhite = isBlack Set wksSheet = printRange.Parent With wksSheet.PageSetup .Orientation = xlPortrait .Zoom = False .FitToPagesTall = 1 .FitToPagesWide = 1 End With Select Case MsgBox("Are you sure you would like to print the selected page?", vbYesNo Or vbQuestion Or vbDefaultButton1, reducePaperTitle) Case vbYes Select Case MsgBox("Really?", vbYesNo Or vbQuestion Or vbDefaultButton1, reducePaperTitle) Case vbYes printRange.PrintOut End Select End Select On Error GoTo 0 Exit Sub PrintPage_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PrintPage of Modul mod_Drucken" End Sub Sub DeleteDrawingObjects(wks As Worksheet) Dim i As Long For i = wks.DrawingObjects().Count To 1 Step -1 wks.DrawingObjects(i).Delete Next i End Sub Public Sub UnhideAll() Dim wks As Worksheet For Each wks In ThisWorkbook.Worksheets wks.Visible = xlSheetVisible Next UnprotectAll End Sub Public Sub UnprotectAll() Dim i As Long For i = ThisWorkbook.Worksheets.Count To 1 Step -1 ThisWorkbook.Worksheets(i).Unprotect Password:=WORKSHEET_UNPROTECT_PASSWORD Next i End Sub Public Sub HideNeededWorksheets() Dim varSheet As Variant Dim visibleSheets As Variant Dim hiddenSheets As Variant OnStart visibleSheets = Array(tblInput) hiddenSheets = Array(tblSettings) For Each varSheet In visibleSheets varSheet.Visible = xlSheetVisible Next varSheet For Each varSheet In hiddenSheets varSheet.Visible = xlSheetVeryHidden Next varSheet OnEnd End Sub Public Sub AddCommentToSelection(myComment As Range) Dim myCell As Range For Each myCell In Selection myCell.ClearComments myCell.AddComment myComment.Text myCell.Comment.Visible = False myCell.Comment.Shape.ScaleWidth 4, msoFalse, msoScaleFromTopLeft myCell.Comment.Shape.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft Next myCell End Sub Sub PrintAllNames() Dim nm As Name For Each nm In ThisWorkbook.Names Debug.Print nm.Name Next nm End Sub Sub DeleteAllNames() Dim nm As Name For Each nm In ThisWorkbook.Names Debug.Print nm.Name & " is deleted!" nm.Delete Next nm End Sub Public Sub DeleteCommentInSelection() If SET_IN_PRODUCTION Then On Error GoTo DeleteCommentInSelection_Error Dim myCell As Range For Each myCell In Selection myCell.ClearComments Next myCell On Error GoTo 0 Exit Sub DeleteCommentInSelection_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DeleteCommentInSelection of Sub mod_StandardSubs" End Sub Public Sub SelectMeA1RangeEverywhere() If SET_IN_PRODUCTION Then On Error GoTo SelectMeA1RangeEverywhere_Error Dim wks As Worksheet For Each wks In ThisWorkbook.Worksheets If wks.Visible = xlSheetVisible Then wks.Activate wks.Cells(1, 1).Select End If Next Worksheets(1).Select On Error GoTo 0 Exit Sub SelectMeA1RangeEverywhere_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SelectMeA1RangeEverywhere of Sub mod_StandardSubs" End Sub Sub HideShowComments(Optional showComments As Boolean = False, _ Optional myRange As Range = Nothing) Dim myCell As Range If SET_IN_PRODUCTION Then On Error GoTo HideShowComments_Error If myRange Is Nothing Then Set myRange = Range("A1:AO1000") For Each myCell In myRange If Not myCell.Comment Is Nothing Then myCell.Comment.Visible = showComments End If Next myCell On Error GoTo 0 Exit Sub HideShowComments_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure HideShowComments of Sub mod_StandardSubs" End Sub Public Sub ResetAndUnlock() If Not IsValueInArray(Environ("Username"), ADMINS, True) Then Debug.Print "no" Exit Sub End If UnhideAll 'UnprotectAll is included Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" ActiveWindow.DisplayHeadings = True Application.DisplayFormulaBar = True Debug.Print "Done." EnableMySaves End Sub Public Sub EnableMySaves() Application.OnKey "%{F11}" Application.OnKey "^c" Application.OnKey "^C" Application.OnKey "^v" Application.OnKey "^V" Application.OnKey "^x" Application.OnKey "^X" Application.OnKey "^w" Application.OnKey "^W" Application.OnKey "^e" Application.OnKey "^E" End Sub Public Sub DisabledCombination() 'This is the disabled combination for Application.OnKey End Sub Public Sub DisableShortcutsAndSaves() Application.OnKey "^c", "DisabledCombination" Application.OnKey "^C", "DisabledCombination" Application.OnKey "^v", "DisabledCombination" Application.OnKey "^V", "DisabledCombination" Application.OnKey "^x", "DisabledCombination" Application.OnKey "^X", "DisabledCombination" Application.OnKey "^w", "DisabledCombination" Application.OnKey "^W", "DisabledCombination" Application.OnKey "^e", "ShowMainForm" Application.OnKey "^E", "ShowMainForm" End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/ExcelVBE.bas ================================================ Attribute VB_Name = "ExcelVBE" Option Explicit Option Private Module Sub PrintAllCode() Dim item As Variant Dim textToPrint As String Dim lineToPrint As String For Each item In ThisWorkbook.vbProject.VBComponents lineToPrint = item.codeModule.lines(1, item.codeModule.CountOfLines) Debug.Print lineToPrint textToPrint = textToPrint & vbCrLf & lineToPrint Next item PrintToNotepad textToPrint End Sub Sub PrintAllContainers() Dim item As Variant Dim textToPrint As String Dim lineToPrint As String For Each item In ThisWorkbook.vbProject.VBComponents lineToPrint = item.Name Debug.Print lineToPrint textToPrint = textToPrint & vbCrLf & lineToPrint Next item PrintToNotepad textToPrint End Sub Sub ListProcedures(Optional modName As String = "ExcelAdditional", Optional withParentInfo As Boolean = False) Dim project As VBIDE.vbProject Dim component As VBIDE.VBComponent Dim codeModule As VBIDE.codeModule Dim lineNum As Long Dim procName As String Dim procKind As VBIDE.vbext_ProcKind Dim subsInfo As String Set project = ThisWorkbook.vbProject Set component = project.VBComponents(modName) Set codeModule = component.codeModule With codeModule lineNum = .CountOfDeclarationLines + 1 Do Until lineNum >= .CountOfLines procName = .ProcOfLine(lineNum, procKind) If withParentInfo Then subsInfo = subsInfo & IIf(subsInfo = vbNullString, vbNullString, vbCrLf) & modName & "." & procName Else subsInfo = subsInfo & IIf(subsInfo = vbNullString, vbNullString, vbCrLf) & procName End If lineNum = .ProcStartLine(procName, procKind) + .ProcCountLines(procName, procKind) + 1 Loop End With Debug.Print subsInfo PrintToNotepad subsInfo End Sub Sub ExportModules() CreateFolderOnDesktop GetFolderOnDesktopPath On Error Resume Next Kill GetFolderOnDesktopPath & "\*.*" On Error GoTo 0 Dim wkb As Workbook: Set wkb = Excel.Workbooks(ThisWorkbook.Name) If wkb.vbProject.Protection = vbext_pp_locked Then Debug.Print "The VBA in this workbook is locked." Exit Sub End If Dim unitsCount As Long Dim filePath As String Dim component As VBIDE.VBComponent Dim tryExport As Boolean For Each component In wkb.vbProject.VBComponents tryExport = True filePath = component.Name Select Case component.Type Case vbext_ct_ClassModule filePath = filePath & ".cls" Case vbext_ct_MSForm filePath = filePath & ".frm" Case vbext_ct_StdModule filePath = filePath & ".bas" Case vbext_ct_Document tryExport = False End Select If tryExport Then Increment unitsCount Debug.Print unitsCount & " exporting " & filePath component.export GetFolderOnDesktopPath & filePath End If Next Debug.Print "Exported at " & GetFolderOnDesktopPath End Sub Function GetFolderOnDesktopPath() As String Dim shell As Object Dim fso As Object Dim specialFolderPath As String Set shell = CreateObject("WScript.Shell") Set fso = CreateObject("scripting.filesystemobject") specialFolderPath = shell.SpecialFolders("Desktop") If Right(specialFolderPath, 1) <> "\" Then specialFolderPath = specialFolderPath & "\" GetFolderOnDesktopPath = specialFolderPath & CON_STR_APP_NAME & "\" End Function Sub CreateFolderOnDesktop(specialFolderPath As String) On Error Resume Next MkDir specialFolderPath If Err.Number <> 0 Then If Err.Number = 75 Then Debug.Print "Folder exists - " & specialFolderPath Else Err.Raise Err.Number, Err.source, Err.Description End If Else Debug.Print "Folder has been created - " & specialFolderPath End If On Error GoTo 0 End Sub Public Sub ImportModules() '1. The target workbook should be opened in the same Excel instance as the ThisWorkbook '2. The target workbook should be in the same directory as ThisWorkbook '3. The code to be added should be present in GetFolderOnDesktopPath Dim targetName As String: targetName = "empty.xlsm" Dim targetPath As String: targetPath = ThisWorkbook.path & "\" & targetName Dim wkbTarget As Workbook Dim fso As Scripting.FileSystemObject Dim file As Scripting.file Dim codePath As String: codePath = GetFolderOnDesktopPath Set wkbTarget = Workbooks(targetName) If wkbTarget.vbProject.Protection = 1 Then Debug.Print "VBProject is protected!" End If Set fso = New Scripting.FileSystemObject If fso.GetFolder(codePath).Files.Count = 0 Then Debug.Print "Zero vba files in source workbook!" Exit Sub End If DeleteAllVba wkbTarget Dim unitsCount As Long For Each file In fso.GetFolder(codePath).Files Select Case fso.GetExtensionName(file.Name) Case "cls", "frm", "bas": Increment unitsCount Debug.Print unitsCount & " -> in " & wkbTarget.Name & " adding " & file.Name wkbTarget.vbProject.VBComponents.Import file.path Case Else: Debug.Print file.Name & " cannot be processed." End Select Next Debug.Print vbCrLf & unitsCount & " units were just added to:" & vbCrLf & targetPath End Sub Function DeleteAllVba(wkbTarget As Workbook) Dim project As VBIDE.vbProject Dim component As VBIDE.VBComponent Dim unitsCount As Long Set project = wkbTarget.vbProject For Each component In project.VBComponents If component.Type <> vbext_ct_Document Then Increment unitsCount Debug.Print unitsCount & " from " & wkbTarget.Name & " deleting " & component.Name project.VBComponents.Remove component End If Next Debug.Print 'Empty line is good :) End Function ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/VersionsAbout.bas ================================================ Attribute VB_Name = "VersionsAbout" Option Explicit Option Private Module '================================================================================================================== '=======================================CREDITS==================================================================== '================================================================================================================== 'TDD classes are taken with some changes from: ' https://github.com/VBA-tools/vba-test 'Form ideas are from: ' https://www.vitoshacademy.com/vba-the-perfect-userform-in-vba/ ' https://codereview.stackexchange.com/questions/154401/handling-dialog-closure-in-a-vba-user-form 'Most of the code is present also at: ' https://github.com/Vitosh/VBA_personal 'The offisial site and GitHub repo of the Boilerplate: ' https://www.vitoshacademy.com/boilerplate ' https://github.com/Vitosh/VBA_personal/tree/master/Boilerplate '================================================================================================================== '=======================================VERSIONS=================================================================== '================================================================================================================== 'Boiler Plate Version 8.0.3: ' Vitosh - 23.12.2019 ' ' Minor fixes: ' - Fix RangeIsZeroOrEmpty ' - Fix the credits with the correct url ' - Fix spaces, remove some lines, fix variables ' - Adding "DecodifyTime" to return "CodifyTime" back '------------------------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------------------------- 'Boiler Plate Version 8.0.: ' Vitosh - 19.12.2019 ' ' Openning the project, removing the password ' Trying to remove words like "Call" and fix variables names ' Structuring the code (that's a lot!) '------------------------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------------------------- 'Boiler Plate Version 7.0.: ' Vitosh - 16.03.2017 ' ' Add CON_STR_APP_NAME = "Boilerplate Project Name" ' A new form, with a new class is implemented ' Change to xlsb ' Move all named ranges from Settings as Constants '------------------------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------------------------- 'Boiler Plate Version 6.0.: ' Vitosh - 01.2017 ' ' Check for more opened instances ' TDD implemented ' Standard Functions and subs ' On openning: ' fixing outlook ' hiding whatever possible ' checking for another instance opened ' frmInfo with lblInfo is present ' adding new sheet is disabled ' beforeclose sheet function is present '================================================================================================================== '=======================================THANK YOU (YES, YOU!)====================================================== '================================================================================================================== 'As far as you are looking into these credits, most probably you are a VBA developer! ' 'As a VBA developer, you have probably heard hundres of times that you are not a real developer or anything 'like this from random people - from high end clean code gurus to java guys, who learned about programming 'some 2 weeks ago. Anyway, it does not matter. You are a developer! (and don't listen to these guys, most of them 'are deeply confused in general) ' ' Thank you for all the awesome #VBA code you have written! ' It matters! You matter! ' Stay awesome! ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/formExample.bas ================================================ Attribute VB_Name = "formExample" Option Explicit Option Private Module Private presenter As formSummaryPresenter Public Sub FormExampleMain() presenter.ChangeLabelAndCaption "Starting and running...", "Running..." GenerateNumbers End Sub Public Sub GenerateNumbers(Optional outerLoopLimit As Long = 2, Optional innerLoopLimit As Long = 4) Dim a As Long Dim b As Long For a = 1 To outerLoopLimit For b = 1 To innerLoopLimit Debug.Print a * b Next Next Debug.Print "-------END-------" & vbCrLf & Now End Sub Public Sub ShowMainForm() If (presenter Is Nothing) Then Set presenter = New formSummaryPresenter End If presenter.Show End Sub Public Sub CheckHowManyWbAreOpened() On Error GoTo CheckHowManyWbAreOpened_Error If Workbooks.Count > 1 Then PUB_STR_ERROR_REPORT = True frmInfo.Show (vbModeless) Application.Wait (Now + TimeValue("00:00:02")) Unload frmInfo End If PUB_STR_ERROR_REPORT = False On Error GoTo 0 Exit Sub CheckHowManyWbAreOpened_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CheckHowManyWbAreOpened of Sub DieseArbeitsmappe" End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/formSummaryPresenter.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "formSummaryPresenter" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private WithEvents summaryForm As frmExample Attribute summaryForm.VB_VarHelpID = -1 Private Sub Class_Initialize() Set summaryForm = New frmExample End Sub Private Sub Class_Terminate() Set summaryForm = Nothing End Sub Public Sub Show() If Not summaryForm.Visible Then summaryForm.Show vbModeless ChangeLabelAndCaption "Press Run to Start", "Starting" End If With summaryForm .Top = CLng((Application.Height / 2 + Application.Top) - .Height / 2) .Left = CLng((Application.Width / 2 + Application.Left) - .Width / 2) .caption = CON_STR_APP_NAME End With End Sub Private Sub Hide() If summaryForm.Visible Then summaryForm.Hide End Sub Public Sub ChangeLabelAndCaption(labelInfo As String, caption As String) summaryForm.InformationText = labelInfo summaryForm.InformationCaption = caption summaryForm.Repaint End Sub Private Sub summaryForm_OnRunReport() FormExampleMain Refresh End Sub Private Sub summaryForm_OnExit() Hide End Sub Public Sub Refresh() With summaryForm .lblInfo = "Ready" .caption = "Task performed" End With End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/frmExample.frm ================================================ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} FrmExample Caption = "UserForm1" ClientHeight = 4404 ClientLeft = -12 ClientTop = 120 ClientWidth = 5388 OleObjectBlob = "frmExample.frx":0000 StartUpPosition = 1 'Fenstermitte End Attribute VB_Name = "frmExample" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Public Event OnRunReport() Public Event OnExit() Public Property Get InformationText() As String InformationText = lblInfo.caption End Property Public Property Let InformationText(ByVal value As String) lblInfo.caption = value End Property Public Property Get InformationCaption() As String InformationCaption = caption End Property Public Property Let InformationCaption(ByVal value As String) caption = value End Property Private Sub btnRun_Click() RaiseEvent OnRunReport End Sub Private Sub btnExit_Click() RaiseEvent OnExit End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then Cancel = True Hide End If End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/frmInfo.frm ================================================ VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} FrmInfo ClientHeight = 1440 ClientLeft = -156 ClientTop = -564 ClientWidth = 2772 OleObjectBlob = "frmInfo.frx":0000 StartUpPosition = 1 'Fenstermitte End Attribute VB_Name = "frmInfo" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Sub UserForm_Initialize() If PUB_STR_ERROR_REPORT Then Me.lblInformation = CON_STR_INSTANCES_LOG End If With Me .StartUpPosition = 0 .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width) .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height) .caption = CON_STR_APP_NAME End With End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/tblInput.vb ================================================ Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveWindow.Zoom > 100 Or ActiveWindow.Zoom < 70 Then ActiveWindow.Zoom = 100 End If End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/tddMain.bas ================================================ Attribute VB_Name = "tddMain" Option Explicit Option Private Module Sub Tdd(Optional export As Boolean = False) On Error Resume Next Dim specs As New tddSpecSuite Debug.Print "Test report from " & Environ("Username") & vbCrLf & "START: " & Now() & vbCrLf PUB_STR_ERROR_REPORT = "Test report from " & Environ("Username") & vbCrLf & "START: " & Now() & vbCrLf '--------------------- 'Tests start here ---v 'Test Scenario #1 TestMeSample Dim myarr(16) As Variant Dim arrCounter As Long Dim myCell As Range myarr(1) = 1.81859485365136 myarr(2) = -4.79462137331569 myarr(3) = -0.713935644387188 myarr(4) = -8.38308001079428 myarr(5) = 24.9643391023361 myarr(6) = -27.4617351821139 myarr(7) = 64.2321735505502 myarr(8) = -88.9405995522673 myarr(9) = -127.858501929498 myarr(10) = 101.737867039937 myarr(11) = 146.707455130634 myarr(12) = -120.333197895024 myarr(13) = 772.275323251858 myarr(14) = 1129.5172126244 myarr(15) = 1312.97247658607 myarr(16) = -349.11864840751 For Each myCell In tblInput.Range("A1:B8") Increment arrCounter specs.It("Scenario 1." & CStr(arrCounter)).Expect(myarr(arrCounter)).ToEqual myCell.value Next myCell 'Test Scenario #2 specs.It("Scenario 2.1").Expect(SumArray(Array(1, 2, 3))).ToEqual 6 specs.It("Scenario 2.2").Expect(SumArray(Array(3, 3, 3))).ToEqual 9 specs.It("Scenario 2.3").Expect(SumArray(Array(3, 4, 3))).ToNotEqual 9 specs.It("Scenario 2.4").Expect(SumArray(Array(3, 3, 100), 1)).ToEqual 6 specs.It("Scenario 2.5").Expect(SumArray(Array(3, 3, 100))).ToEqual 106 specs.It("Scenario 2.6").Expect(SumArray(Array(-3, -3))).ToEqual -6 'Tests Scenario #3 specs.It("Scenario 3.1").Expect(ColumnNumberToLetter(26)).ToEqual "Z" specs.It("Scenario 3.2").Expect(ColumnNumberToLetter(1)).ToEqual "A" '--------------------- 'Tests end here -----^ tddSpecInlineRunner.RunSuite specs specs.TotalTests PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & "END: " & Now() & vbCrLf Debug.Print "END: " & Now() & vbCrLf If export Then PrintToNotepad On Error GoTo 0 End Sub Public Sub MakeAllValues() Dim myCell As Range Dim i As Long Dim str As String For Each myCell In Selection Increment i str = vbTab & "myArr(" & i & ")= " If Len(myCell) > 0 Then If IsDate(myCell) Then str = str & "CDate(""" & myCell & """)" Else If Not IsNumeric(myCell) Then str = str & """" & myCell & """" Else str = str & ChangeCommas(myCell.value) End If End If Else If myCell.HasFormula Then str = str & """""" Else str = str & 0 End If End If Debug.Print str Next myCell End Sub Sub TestMeSample() Dim myCell As Range Dim myVal As Variant For Each myCell In tblInput.Range("A1:B8") myVal = myVal * 1.5 + 2 myCell = myVal * Sin(myVal) Next End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/tddSpecDefinition.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "tddSpecDefinition" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = True Option Explicit Private pExpectations As Collection Private pFailedExpectations As Collection Public Description As String Public Id As String Public Enum SpecResult Pass Fail Pending End Enum Public Property Get Expectations() As Collection If pExpectations Is Nothing Then Set pExpectations = New Collection End If Set Expectations = pExpectations End Property Private Property Let Expectations(value As Collection) Set pExpectations = value End Property Public Property Get FailedExpectations() As Collection If pFailedExpectations Is Nothing Then Set pFailedExpectations = New Collection End If Set FailedExpectations = pFailedExpectations End Property Private Property Let FailedExpectations(value As Collection) Set pFailedExpectations = value End Property Public Function Expect(Optional value As Variant) As tddSpecExpectation Dim Exp As New tddSpecExpectation If VarType(value) = vbObject Then Set Exp.Actual = value Else Exp.Actual = value End If Me.Expectations.Add Exp Set Expect = Exp End Function Public Function Result() As SpecResult Dim Exp As tddSpecExpectation FailedExpectations = New Collection If Me.Expectations.Count < 1 Then Result = Pending Else For Each Exp In Me.Expectations If Exp.Result = Fail Then FailedExpectations.Add Exp End If Next Exp If Me.FailedExpectations.Count > 0 Then Result = Fail Else Result = Pass End If End If End Function Public Function ResultName() As String Select Case Me.Result Case Pass: ResultName = "Pass" Case Fail: ResultName = "Fail" Case Pending: ResultName = "Pending" End Select End Function ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/tddSpecExpectation.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "tddSpecExpectation" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = True Option Explicit Public Actual As Variant Public Expected As Variant Public Result As ExpectResult Public FailureMessage As String Public Enum ExpectResult Pass Fail End Enum Public Sub ToEqual(Expected As Variant) Check IsEqual(Me.Actual, Expected), "to equal", Expected:=Expected End Sub Public Sub ToNotEqual(Expected As Variant) Check IsEqual(Me.Actual, Expected), "to not equal", Expected:=Expected, Inverse:=True End Sub Private Function IsEqual(Actual As Variant, Expected As Variant) As Variant Dim l_count As Long If IsArray(Expected) Then If UBound(Expected) <> UBound(Actual) Then IsEqual = False: Exit Function For l_count = LBound(Expected) To UBound(Expected) If Not Expected(l_count) = Actual(l_count) Then IsEqual = False: Exit Function Next l_count IsEqual = True End If If IsError(Actual) Or IsError(Expected) Then IsEqual = False ElseIf IsObject(Actual) Or IsObject(Expected) Then IsEqual = "Unsupported: Can't compare objects" ElseIf VarType(Actual) = vbDouble And VarType(Expected) = vbDouble Then IsEqual = IsCloseTo(Actual, Expected, 15) Else IsEqual = Actual = Expected End If End Function Public Sub ToBeDefined() Debug.Print "Excel-TDD: DEPRECATED, ToBeDefined() has been deprecated in favor of ToNotBeUndefined and will be removed in Excel-TDD v2.0.0" Check IsUndefined(Me.Actual), "to be defined", Inverse:=True End Sub Public Sub ToBeUndefined() Check IsUndefined(Me.Actual), "to be undefined" End Sub Public Sub ToNotBeUndefined() Check IsUndefined(Me.Actual), "to not be undefined", Inverse:=True End Sub Private Function IsUndefined(Actual As Variant) As Variant IsUndefined = IsNothing(Actual) Or isEmpty(Actual) Or IsNull(Actual) Or IsMissing(Actual) End Function Public Sub ToBeNothing() Check IsNothing(Me.Actual), "to be nothing" End Sub Public Sub ToNotBeNothing() Check IsNothing(Me.Actual), "to not be nothing", Inverse:=True End Sub Private Function IsNothing(Actual As Variant) As Variant If IsObject(Actual) Then If Actual Is Nothing Then IsNothing = True Else IsNothing = False End If Else IsNothing = False End If End Function Public Sub ToBeEmpty() Check isEmpty(Me.Actual), "to be empty" End Sub Public Sub ToNotBeEmpty() Check isEmpty(Me.Actual), "to not be empty", Inverse:=True End Sub Public Sub ToBeNull() Check IsNull(Me.Actual), "to be null" End Sub Public Sub ToNotBeNull() Check IsNull(Me.Actual), "to not be null", Inverse:=True End Sub Public Sub ToBeMissing() Check IsMissing(Me.Actual), "to be missing" End Sub Public Sub ToNotBeMissing() Check IsMissing(Me.Actual), "to not be missing", Inverse:=True End Sub Public Sub ToBeLessThan(Expected As Variant) Check IsLT(Me.Actual, Expected), "to be less than", Expected:=Expected End Sub Public Sub ToBeLT(Expected As Variant) ToBeLessThan Expected End Sub Private Function IsLT(Actual As Variant, Expected As Variant) As Variant If IsError(Actual) Or IsError(Expected) Or Actual >= Expected Then IsLT = False Else IsLT = True End If End Function Public Sub ToBeLessThanOrEqualTo(Expected As Variant) Check IsLTE(Me.Actual, Expected), "to be less than or equal to", Expected:=Expected End Sub Public Sub ToBeLTE(Expected As Variant) ToBeLessThanOrEqualTo Expected End Sub Private Function IsLTE(Actual As Variant, Expected As Variant) As Variant If IsError(Actual) Or IsError(Expected) Or Actual > Expected Then IsLTE = False Else IsLTE = True End If End Function Public Sub ToBeGreaterThan(Expected As Variant) Check IsGT(Me.Actual, Expected), "to be greater than", Expected:=Expected End Sub Public Sub ToBeGT(Expected As Variant) ToBeGreaterThan Expected End Sub Private Function IsGT(Actual As Variant, Expected As Variant) As Variant If IsError(Actual) Or IsError(Expected) Or Actual <= Expected Then IsGT = False Else IsGT = True End If End Function Public Sub ToBeGreaterThanOrEqualTo(Expected As Variant) Check IsGTE(Me.Actual, Expected), "to be greater than or equal to", Expected:=Expected End Sub Public Sub ToBeGTE(Expected As Variant) ToBeGreaterThanOrEqualTo Expected End Sub Private Function IsGTE(Actual As Variant, Expected As Variant) As Variant If IsError(Actual) Or IsError(Expected) Or Actual < Expected Then IsGTE = False Else IsGTE = True End If End Function Public Sub ToBeCloseTo(Expected As Variant, SignificantFigures As Long) Check IsCloseTo(Me.Actual, Expected, SignificantFigures), "to be close to", Expected:=Expected End Sub Public Sub ToNotBeCloseTo(Expected As Variant, SignificantFigures As Long) Check IsCloseTo(Me.Actual, Expected, SignificantFigures), "to be close to", Expected:=Expected, Inverse:=True End Sub Private Function IsCloseTo(Actual As Variant, Expected As Variant, SignificantFigures As Long) As Variant Dim ActualAsString As String Dim ExpectedAsString As String If SignificantFigures < 1 Or SignificantFigures > 15 Then IsCloseTo = "ToBeCloseTo/ToNotBeClose to can only compare from 1 to 15 significant figures""" ElseIf Not IsError(Actual) And Not IsError(Expected) Then If Actual > 1 Then ActualAsString = VBA.Format$(Actual, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e+0") Else ActualAsString = VBA.Format$(Actual, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e-0") End If If Expected > 1 Then ExpectedAsString = VBA.Format$(Expected, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e+0") Else ExpectedAsString = VBA.Format$(Expected, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e-0") End If IsCloseTo = ActualAsString = ExpectedAsString End If End Function Public Sub ToContain(Expected As Variant, Optional MatchCase As Boolean = True) If VarType(Me.Actual) = vbString Then Debug.Print "Excel-TDD: DEPRECATED ToContain has been changed to ToMatch in Excel-TDD v2.0.0" If MatchCase Then Check Matches(Me.Actual, Expected), "to match", Expected:=Expected Else Check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), "to match", Expected:=Expected End If Else Check Contains(Me.Actual, Expected), "to contain", Expected:=Expected End If End Sub Public Sub ToNotContain(Expected As Variant, Optional MatchCase As Boolean = True) If VarType(Me.Actual) = vbString Then Debug.Print "Excel-TDD: DEPRECATED ToNotContain has been changed to ToMatch in Excel-TDD v2.0.0" If MatchCase Then Check Matches(Me.Actual, Expected), "to not match", Expected:=Expected, Inverse:=True Else Check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), "to not match", Expected:=Expected, Inverse:=True End If Else Check Contains(Me.Actual, Expected), "to not contain", Expected:=Expected, Inverse:=True End If End Sub Private Function Contains(Actual As Variant, Expected As Variant) As Variant If Not IsArray(Actual) Then Contains = "Error: Actual needs to be an Array or Collection for ToContain/ToNotContain" Else Dim i As Long If TypeOf Actual Is Collection Then For i = 1 To Actual.Count If Actual.item(i) = Expected Then Contains = True Exit Function End If Next i Else For i = LBound(Actual) To UBound(Actual) If Actual(i) = Expected Then Contains = True Exit Function End If Next i End If End If End Function Public Sub ToMatch(Expected As Variant) Check Matches(Me.Actual, Expected), "to match", Expected:=Expected End Sub Public Sub ToNotMatch(Expected As Variant) Check Matches(Me.Actual, Expected), "to not match", Expected:=Expected, Inverse:=True End Sub Private Function Matches(Actual As Variant, Expected As Variant) As Variant If InStr(Actual, Expected) > 0 Then Matches = True Else Matches = False End If End Function Public Sub RunMatcher(Name As String, Message As String, ParamArray Arguments()) Dim Expected As String Dim i As Long Dim HasArguments As Boolean HasArguments = UBound(Arguments) >= 0 For i = LBound(Arguments) To UBound(Arguments) If Expected = "" Then Expected = GetStringForValue(Arguments(i)) ElseIf i = UBound(Arguments) Then If (UBound(Arguments) > 1) Then Expected = Expected & ", and " & GetStringForValue(Arguments(i)) Else Expected = Expected & " and " & GetStringForValue(Arguments(i)) End If Else Expected = Expected & ", " & GetStringForValue(Arguments(i)) End If Next i If HasArguments Then Check Application.Run(Name, Me.Actual, Arguments), Message, Expected:=Expected Else Check Application.Run(Name, Me.Actual), Message End If End Sub Private Sub Check(Result As Variant, Message As String, Optional Expected As Variant, Optional Inverse As Boolean = False) If Not IsMissing(Expected) Then If IsObject(Expected) Then Set Me.Expected = Expected Else Me.Expected = Expected End If End If If VarType(Result) = vbString Then Fails CStr(Result) Else If Inverse Then Result = Not Result End If If Result Then Passes Else Fails CreateFailureMessage(Message, Expected) End If End If End Sub Private Sub Passes() Me.Result = ExpectResult.Pass End Sub Private Sub Fails(Message As String) Me.Result = ExpectResult.Fail Me.FailureMessage = Message End Sub Private Function CreateFailureMessage(Message As String, Optional Expected As Variant) As String CreateFailureMessage = "Expected " & GetStringForValue(Me.Actual) & " " & Message If Not IsMissing(Expected) Then CreateFailureMessage = CreateFailureMessage & " " & GetStringForValue(Expected) End If End Function Private Function GetStringForValue(value As Variant) As String If IsObject(value) Then If value Is Nothing Then GetStringForValue = "(Nothing)" Else GetStringForValue = "(Object)" End If ElseIf IsArray(value) Then GetStringForValue = "(Array)" ElseIf isEmpty(value) Then GetStringForValue = "(Empty)" ElseIf IsNull(value) Then GetStringForValue = "(Null)" ElseIf IsMissing(value) Then GetStringForValue = "(Missing)" Else GetStringForValue = CStr(value) End If If GetStringForValue = "" Then GetStringForValue = "(Undefined)" End If End Function Private Function IsArray(value As Variant) As Boolean If Not isEmpty(value) Then If IsObject(value) Then If TypeOf value Is Collection Then IsArray = True End If ElseIf VarType(value) = vbArray Or VarType(value) = 8204 Then IsArray = True End If End If End Function ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/tddSpecInlineRunner.bas ================================================ Attribute VB_Name = "tddSpecInlineRunner" Option Explicit Option Private Module Public Sub RunSuite(specs As tddSpecSuite, Optional ShowFailureDetails As Boolean = True, Optional ShowPassed As Boolean = False, Optional ShowSuiteDetails As Boolean = False) Dim SuiteCol As New Collection SuiteCol.Add specs RunSuites SuiteCol, ShowFailureDetails, ShowPassed, ShowSuiteDetails End Sub Public Sub RunSuites(SuiteCol As Collection, Optional ShowFailureDetails As Boolean = True, Optional ShowPassed As Boolean = False, Optional ShowSuiteDetails As Boolean = True) Dim Suite As tddSpecSuite Dim Spec As tddSpecDefinition Dim TotalCount As Long Dim FailedSpecs As Long Dim PendingSpecs As Long Dim ShowingResults As Boolean Dim Indentation As String For Each Suite In SuiteCol If Not Suite Is Nothing Then TotalCount = TotalCount + Suite.SpecsCol.Count For Each Spec In Suite.SpecsCol If Spec.Result = SpecResult.Fail Then FailedSpecs = FailedSpecs + 1 ElseIf Spec.Result = SpecResult.Pending Then PendingSpecs = PendingSpecs + 1 End If Next Spec End If Next Suite Debug.Print "= " & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & " = " & Now & " =========================" PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & "= " & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & " = " & Now & " =========================" & vbCrLf For Each Suite In SuiteCol If Not Suite Is Nothing Then If ShowSuiteDetails Then Debug.Print SuiteMessage(Suite) Indentation = " " ShowingResults = True Else Indentation = "" End If For Each Spec In Suite.SpecsCol If Spec.Result = SpecResult.Fail Then Debug.Print Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation) PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation) & vbCrLf ShowingResults = True ElseIf Spec.Result = SpecResult.Pending Then Debug.Print Indentation & PendingMessage(Spec) PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & Indentation & PendingMessage(Spec) & vbCrLf ShowingResults = True ElseIf ShowPassed Then Debug.Print Indentation & PassingMessage(Spec) PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & Indentation & PassingMessage(Spec) & vbCrLf ShowingResults = True End If Next Spec End If Next Suite If ShowingResults Then Debug.Print "===" PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & "===" & vbCrLf End If End Sub Private Function SummaryMessage(TotalCount As Long, FailedSpecs As Long, PendingSpecs As Long) As String If FailedSpecs = 0 Then SummaryMessage = "PASS (" & TotalCount - PendingSpecs & " of " & TotalCount & " passed" Else SummaryMessage = "FAIL (" & FailedSpecs & " of " & TotalCount & " failed" End If If PendingSpecs = 0 Then SummaryMessage = SummaryMessage & ")" Else SummaryMessage = SummaryMessage & ", " & PendingSpecs & " pending)" End If End Function Private Function FailureMessage(Spec As tddSpecDefinition, ShowFailureDetails As Boolean, Indentation As String) As String Dim FailedExpectation As tddSpecExpectation Dim i As Long FailureMessage = ResultMessage(Spec, "X") If ShowFailureDetails Then FailureMessage = FailureMessage & vbNewLine For Each FailedExpectation In Spec.FailedExpectations FailureMessage = FailureMessage & Indentation & " " & FailedExpectation.FailureMessage If i + 1 <> Spec.FailedExpectations.Count Then: FailureMessage = FailureMessage & vbNewLine i = i + 1 Next FailedExpectation End If End Function Private Function PendingMessage(Spec As tddSpecDefinition) As String PendingMessage = ResultMessage(Spec, ".") End Function Private Function PassingMessage(Spec As tddSpecDefinition) As String PassingMessage = ResultMessage(Spec, "+") End Function Private Function ResultMessage(Spec As tddSpecDefinition, Symbol As String) As String ResultMessage = Symbol & " " If Spec.Id <> "" Then ResultMessage = ResultMessage & Spec.Id & ": " End If ResultMessage = ResultMessage & Spec.Description End Function Private Function SuiteMessage(Suite As tddSpecSuite) As String Dim HasFailures As Boolean Dim Spec As tddSpecDefinition For Each Spec In Suite.SpecsCol If Spec.Result = SpecResult.Fail Then HasFailures = True Exit For End If Next Spec If HasFailures Then SuiteMessage = "X " Else SuiteMessage = "+ " End If If Suite.Description <> "" Then SuiteMessage = SuiteMessage & Suite.Description Else SuiteMessage = SuiteMessage & Suite.SpecsCol.Count & " specs" End If End Function ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/tddSpecSuite.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "tddSpecSuite" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = True Option Explicit Private pSpecsCol As Collection Public Description As String Public BeforeEachCallback As String Public BeforeEachCallbackArgs As Variant Private pCounter As Long Public Property Get SpecsCol() As Collection If pSpecsCol Is Nothing Then: Set pSpecsCol = New Collection Set SpecsCol = pSpecsCol End Property Public Property Let SpecsCol(value As Collection) Set pSpecsCol = value End Property Public Function It(Description As String, Optional SpecId As String = "") As tddSpecDefinition Dim Spec As New tddSpecDefinition pCounter = pCounter + 1 ExecuteBeforeEach Spec.Description = Description Spec.Id = SpecId Me.SpecsCol.Add Spec Set It = Spec End Function Public Sub TotalTests() Debug.Print "Total tests:" & pCounter PUB_STR_ERROR_REPORT = PUB_STR_ERROR_REPORT & "Total tests:" & pCounter & vbCrLf End Sub Public Sub BeforeEach(Callback As String, ParamArray CallbackArgs() As Variant) Me.BeforeEachCallback = Callback Me.BeforeEachCallbackArgs = CallbackArgs End Sub Private Sub ExecuteBeforeEach() If Me.BeforeEachCallback <> "" Then Dim HasArguments As Boolean If VarType(Me.BeforeEachCallbackArgs) = vbObject Then If Not Me.BeforeEachCallbackArgs Is Nothing Then HasArguments = True End If ElseIf IsArray(Me.BeforeEachCallbackArgs) Then If UBound(Me.BeforeEachCallbackArgs) >= 0 Then HasArguments = True End If End If If HasArguments Then Application.Run Me.BeforeEachCallback, Me.BeforeEachCallbackArgs Else Application.Run Me.BeforeEachCallback End If End If End Sub ================================================ FILE: Boilerplate/Boilerplate VitoshAcademy/xl_main.vb ================================================ Option Explicit Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error GoTo Workbook_BeforeClose_Error If Not SET_IN_PRODUCTION Then MsgBox "SET_IN_PRODUCTION" On Error GoTo 0 Cancel = True End If Cancel = False ThisWorkbook.Save Application.DisplayAlerts = False HideNeededWorksheets Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" Application.DisplayAlerts = True ActiveWindow.DisplayHeadings = True Application.DisplayFormulaBar = True 'ActiveSheet.PageSetup.BlackAndWhite = True Me.Save EnableMySaves On Error GoTo 0 Exit Sub Workbook_BeforeClose_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_BeforeClose" End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If Not SET_IN_PRODUCTION Then MsgBox "SET_IN_PRODUCTION", vbInformation, CON_STR_APP_NAME Cancel = True End If End Sub Private Sub Workbook_NewSheet(ByVal Sh As Object) If Not tblSettings.Visible Then With Application Application.ScreenUpdating = False Application.DisplayAlerts = False Sh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End With MsgBox (Environ("UserName") & ", Sie können Blätter nicht hinzufügen."), vbInformation, ThisWorkbook.Name End If End Sub Private Sub Workbook_Open() On Error GoTo Workbook_Open_Error HideNeededWorksheets 'Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", false)" 'Application.DisplayFormulaBar = False If Not IsValueInArray(Environ("username"), ADMINS, True) Then Application.OnKey "%{F11}", "DisabledCombination" End If DisableShortcutsAndSaves If ThisWorkbook.Date1904 Then MsgBox CON_STR_1904, vbInformation, CON_STR_APP_NAME End If Application.WindowState = xlMaximized CheckHowManyWbAreOpened On Error GoTo 0 Exit Sub Workbook_Open_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_Open" Me.Save ThisWorkbook.Close End Sub ================================================ FILE: Boilerplate/CodifyDecodify.vb ================================================ 'Encrypt, encript, 'Decrypt, decript, 'password, check hours Option Explicit Public Const FIRST_ASCII = 97 Public Const LETTERS_NUMBER = 26 Public Function codify_time() As String If [set_in_production] Then On Error GoTo codify_Error Dim dbl_01 As Variant Dim dbl_02 As Variant Dim dbl_now As Double dbl_now = Round(Now(), 8) dbl_01 = Split(CStr(dbl_now), ",")(0) dbl_02 = Split(CStr(dbl_now), ",")(1) codify_time = Hex(dbl_01) & "_" & Hex(dbl_02) On Error GoTo 0 Exit Function codify_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure codify of Function TDD_Export" End Function Public Function codify(str_name) As String Dim l_counter As Long Dim l_number As Long Dim str_number As String Dim str_char As String Dim str_char_result As String Dim str_first As String Dim str_last As String 'making the time For l_counter = 1 To Len(str_name) - 3 str_number = str_number & Mid(str_name, l_counter, 1) Next l_counter l_number = str_number 'making the name For l_counter = 3 To 1 Step -1 str_char = Mid(str_name, Len(str_name) - l_counter + 1, 1) str_char = Chr((Asc(str_char) + l_number) Mod LETTERS_NUMBER) str_char = Chr(Asc(str_char) + FIRST_ASCII) str_char_result = str_char_result & str_char Next l_counter codify = Hex(l_number) & StrReverse(str_char_result) 'now reverse first and last positions str_first = get_in_position(codify, 1) str_last = get_in_position(codify, 1, True) codify = delete_in_position(codify, 1) codify = delete_in_position(codify, Len(codify)) codify = insert_in_position(codify, str_first, Len(codify)) codify = insert_in_position(codify, str_last, 0) codify = LCase(codify) End Function Public Function decodify(str_name) As String Dim l_counter As Long Dim str_char As String Dim str_time As String Dim l_left As Long Dim str_right As String Dim str_first As String Dim str_last As String 'now reverse first and last positions str_first = get_in_position(str_name, 1) str_last = get_in_position(str_name, 1, True) str_name = delete_in_position(str_name, 1) str_name = delete_in_position(str_name, Len(str_name)) str_name = insert_in_position(str_name, str_first, Len(str_name)) str_name = insert_in_position(str_name, str_last, 0) 'making the time For l_counter = 1 To Len(str_name) - 3 str_time = str_time & Mid(str_name, l_counter, 1) Next l_counter l_left = Val("&H" & str_time) 'making the name For l_counter = 3 To 1 Step -1 str_char = Mid(str_name, Len(str_name) - l_counter + 1, 1) str_char = Chr(Asc(str_char) - FIRST_ASCII) str_right = str_right & Chr(mod_where(str_char, l_left)) Next l_counter decodify = l_left & StrReverse(str_right) End Function Public Function format_decodify(str_input As String, Optional b_for_file_name As Boolean = False) As String Dim str_exchange1 As String: str_exchange1 = ":" Dim str_exchange2 As String: str_exchange2 = " " If b_for_file_name Then If Len(str_input) = 9 Then format_decodify = insert_in_position(str_input, str_exchange2, 6) Else format_decodify = insert_in_position(str_input, str_exchange2, 5) End If Exit Function End If If Len(str_input) = 9 Then format_decodify = insert_in_position(str_input, str_exchange1, 2) format_decodify = insert_in_position(format_decodify, str_exchange1, 5) format_decodify = insert_in_position(format_decodify, str_exchange2, 8) Else format_decodify = insert_in_position(str_input, str_exchange1, 1) format_decodify = insert_in_position(format_decodify, str_exchange1, 4) format_decodify = insert_in_position(format_decodify, str_exchange2, 7) End If End Function Public Function mod_where(str As String, l_left As Long) As Long Dim l_counter As Long For l_counter = 0 To LETTERS_NUMBER If ((l_left + l_counter + FIRST_ASCII) Mod LETTERS_NUMBER = Asc(str)) Then mod_where = l_counter + FIRST_ASCII Exit For End If Next l_counter End Function Public Function get_extension() As String get_extension = Replace(Time, ":", "") & Replace(Left(Environ("Username"), 4), ".", "") End Function Function insert_in_position(ByVal source As String, str As String, l As Long) As String 'insert in position insert_in_position = Mid(source, 1, l) & str & Mid(source, l + 1, Len(source) - l) End Function Function delete_in_position(ByVal source As String, l As Long) As String 'delete in position delete_in_position = Mid(source, 1, l - 1) & Mid(source, l + 1, Len(source) - l) End Function Function get_in_position(ByVal str As String, l_position As Long, Optional b_is_last As Boolean = False) As String get_in_position = Mid(str, l_position, 1) If b_is_last Then get_in_position = Mid(str, Len(str), 1) End Function ================================================ FILE: Boilerplate/ConvertNumberToLetter.vb ================================================ Public Function NumberToLetter(number As Long) As String On Error GoTo NumberToLetterError Dim remainder As Long If number < 1 Or number > 2 ^ 14 Then Err.Raise 999, Description:="Error on " & number End If Do While number > 0 remainder = (number - 1) Mod 26 NumberToLetter = Chr(65 + remainder) + NumberToLetter number = (number - remainder) \ 26 Loop Exit Function NumberToLetterError: NumberToLetter = Error End Function Public Sub NumberToLetterTest() Debug.Print NumberToLetter(1) = "A" Debug.Print NumberToLetter(26) = "Z" Debug.Print NumberToLetter(27) = "AA" Debug.Print NumberToLetter(100) = "CV" Debug.Print NumberToLetter(200) = "GR" Debug.Print NumberToLetter(701) = "ZY" Debug.Print NumberToLetter(702) = "ZZ" Debug.Print NumberToLetter(703) = "AAA" Debug.Print NumberToLetter(715) = "AAM" Debug.Print NumberToLetter(1379) = "BAA" Debug.Print NumberToLetter(2055) = "CAA" Debug.Print NumberToLetter(2731) = "DAA" Debug.Print NumberToLetter(704) = "AAB" Debug.Print NumberToLetter(1380) = "BAB" Debug.Print NumberToLetter(2056) = "CAB" Debug.Print NumberToLetter(2732) = "DAB" Debug.Print NumberToLetter(2812) = "DDD" Debug.Print NumberToLetter(5434) = "GZZ" Debug.Print NumberToLetter(8138) = "KZZ" Debug.Print NumberToLetter(16000) = "WQJ" Debug.Print NumberToLetter(16251) = "XAA" Debug.Print NumberToLetter(16384) = "XFD" Debug.Print NumberToLetter(16386) = "Error on 16386" Debug.Print NumberToLetter(-3) = "Error on -3" End Sub Public Function ConvertNumberToLetterExcel(number As Long) As String ConvertNumberToLetterExcel = Split(Cells(1, number).Address, "$")(1) End Function ================================================ FILE: Boilerplate/ExcelGeneral.vb ================================================ Public Sub CloseAllExcelFilesExceptCurrent() Dim wb As Workbook Application.ScreenUpdating = False For Each wb In Workbooks If Not wb.ReadOnly Then wb.Save If wb.Name <> ThisWorkbook.Name Then wb.Close End If Next wb End Sub Public Function ValueInArray(myValue As Variant, myArray As Variant) As Boolean Dim cnt As Long For cnt = LBound(myArray) To UBound(myArray) If LCase(CStr(myValue)) = LCase(CStr(myArray(cnt))) Then valueInArray = True Exit Function End If Next cnt End Function Sub CheckUser() Dim userNames As Variant userNames = Array("User1", "User2", "User3") If valueInArray(Environ("UserName"), userNames) Then Debug.Print "User Present" Else Debug.Print "User Not Present" End If End Sub Sub ChangeTheFont(lookFor As String, currentRange As Range, myColor As Long) Dim startPosition As Long: startPosition = InStr(1, currentRange.Value2, lookFor) Dim endPosition As Long: endPosition = startPosition + Len(currentRange.Value2) With currentRange.Characters(startPosition, Len(lookFor)).Font .Color = myColor .Bold = True End With End Sub Public Function PositionInArray(myValue As Variant, myArray As Variant, Optional timesSeenBefore = 0) As Long Dim i As Long For i = LBound(myArray) To UBound(myArray) If Trim(myValue) = Trim(myArray(i)) Then If timesSeenBefore = 0 Then PositionInArray = i Exit Function Else timesSeenBefore = timesSeenBefore - 1 End If End If Next PositionInArray = -1 End Function Public Sub WriteIfNotZero(myCell As Range, myValue As Variant) If IsError(myValue) Then Dim info As String info = "ExcelError()->" & CStr(myValue) & "->" & myCell.Address & "->" & myCell.Parent.Name & "->" & myCell.Parent.Parent.Name Debug.Print info LogDescription info ElseIf IsNumeric(myValue) Then If CDec(myValue) <> 0 Then myCell.Value2 = myValue End If End If End Sub ================================================ FILE: Boilerplate/Files.vb ================================================ Public Function b_file_exists(ByVal str_file_path As String) As Boolean Dim str_test As String On Error Resume Next str_test = Dir(str_file_path) On Error GoTo 0 b_file_exists = (str_test <> "") End Function 'works in eshare 'eshare file exists Public Function EshareFileExists(filePath) filePath = Replace(filePath, "https:", "") filePath = Replace(filePath, "%20", " ") filePath = Replace(filePath, "/", "\") EshareFileExists = CreateObject("Scripting.FileSystemObject").FileExists(filePath) End Function ================================================ FILE: Boilerplate/Formula.vb ================================================ Public Sub PrintMeUsefulFormula() Dim selectedFormula As String Dim parenthesis As String parenthesis = """" selectedFormula = Selection.Formula selectedFormula = Replace(selectedFormula, """", """""") selectedFormula = parenthesis & selectedFormula & parenthesis Debug.Print selectedFormula End Sub 'A bit untested, use with caution --------v Public Sub PrintMeUsefulFormat() Dim strFormula As String Dim strParenth As String strParenth = """" strFormula = Selection.NumberFormat strFormula = Replace(strFormula, """", """""") strFormula = strParenth & strFormula & strParenth Debug.Print strFormula End Sub 'Column to letter letter to column 'lettertocolumn columntoletter Function ColumnToLetter(columnNumber As Long) As String If columnNumber < 1 Then Exit Function ColumnToLetter = UCase(ColumnToLetter(Int((columnNumber - 1) / 26)) & Chr(((columnNumber - 1) Mod 26) + Asc("A"))) End Function Function LetterToColumn(letters As String) As Long Dim i As Long letters = UCase(letters) For i = Len(letters) To 1 Step -1 LetterToColumn = LetterToColumn + (Asc(Mid(letters, i, 1)) - 64) * 26 ^ (Len(letters) - i) Next End Function Sub Tests() Debug.Print LetterToColumn("a") = 1 Debug.Print LetterToColumn("A") = 1 Debug.Print LetterToColumn("Z") = 26 Debug.Print LetterToColumn("AA") = 27 Debug.Print LetterToColumn("AZ") = 52 Debug.Print LetterToColumn("BA") = 53 Debug.Print ColumnToLetter(1) = "A" Debug.Print ColumnToLetter(26) = "Z" Debug.Print ColumnToLetter(27) = "AA" Debug.Print ColumnToLetter(52) = "AZ" Debug.Print ColumnToLetter(53) = "BA" End Sub ================================================ FILE: Boilerplate/GeneratePathToFolder.vb ================================================ Option Explicit Sub myPathForFolder() Debug.Print GetFolder(Environ("USERPROFILE")) End Sub Function GetFolder(Optional InitialLocation As String) As String On Error GoTo GetFolder_Error Dim FolderDialog As FileDialog Dim SelectedFolder As String If Len(InitialLocation) = 0 Then InitialLocation = ThisWorkbook.Path Set FolderDialog = Excel.Application.FileDialog(msoFileDialogFolderPicker) With FolderDialog .Title = "My Title For Dialog" .AllowMultiSelect = False .InitialFileName = InitialLocation If .Show <> -1 Then GoTo GetFolder_Error SelectedFolder = .SelectedItems(1) End With GetFolder = SelectedFolder On Error GoTo 0 Exit Function GetFolder_Error: Debug.Print "Error " & Err.Number & " (" & Err.Description & ") End Function '--------------------------------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------------------------------- 'Taken from http://www.cpearson.com/excel/browsefolder.aspx Private Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, ByVal pszBuffer As String) As Long Private Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long Private Const MAX_PATH = 260 Function str_BrowseFolder(Optional ByVal DialogTitle As String) As String On Error GoTo str_BrowseFolder_Error ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' BrowseFolder ' This displays the standard Windows Browse Folder dialog. It returns ' the complete path name of the selected folder or vbNullString if the ' user cancelled. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Application.EnableCancelKey = xlDisabled If DialogTitle = vbNullString Then DialogTitle = "Select A Folder" End If Dim uBrowseInfo As BROWSEINFO Dim szBuffer As String Dim lID As Long Dim lRet As Long With uBrowseInfo .hOwner = 0 .pidlRoot = 0 .pszDisplayName = String$(MAX_PATH, vbNullChar) .lpszINSTRUCTIONS = DialogTitle .ulFlags = BIF_RETURNONLYFSDIRS ' + BIF_USENEWUI .lpfn = 0 End With szBuffer = String$(MAX_PATH, vbNullChar) lID = SHBrowseForFolderA(uBrowseInfo) If lID Then ''' Retrieve the path string. lRet = SHGetPathFromIDListA(lID, szBuffer) If lRet Then str_BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1) End If End If Application.EnableCancelKey = xlInterrupt On Error GoTo 0 Exit Function str_BrowseFolder_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure str_BrowseFolder of Function mod_Browse" End Function Public Function FolderIsEmpty(myPath As String) As Boolean 'Checks whether folder is empty FolderIsEmpty = CBool(Dir(myPath & "*.*") = "") End Function Public Function GetDesktopPath() As String GetDesktopPath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" End Function ================================================ FILE: Boilerplate/LastThings.vb ================================================ Option Explicit Option Private Module 'locate last column 'locate last row 'last things count substrings, count strings, count stuff Public Function LastColumn(ws As Worksheet, Optional rowToCheck As Long = 1) As Long LastColumn = ws.Cells(rowToCheck, ws.Columns.count).End(xlToLeft).Column End Function Public Function LastRow(ws As Worksheet, Optional columnToCheck As Long = 1) As Long LastRow = ws.Cells(ws.Rows.count, columnToCheck).End(xlUp).Row End Function Public Function LastUsedColumn(wks As Worksheet) As Long Dim lastCell As Range With wks Set lastCell = .Cells.Find(What:="*", _ After:=.Cells(1, 1), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False) End With LastUsedColumn = lastCell.Column End Function Public Function LocateValueRow(ByVal textTarget As String, _ ByRef wksTarget As Worksheet, _ Optional col As Long = 1, _ Optional moreValuesFound As Long = 1, _ Optional lookForPart = False, _ Optional lookUpToBottom = True) As Long Dim valuesFound As Long Dim localRange As Range Dim myCell As Range Dim lastRowOnColumn1 As Long LocateValueRow = GENERAL_NUMBERS.NF valuesFound = moreValuesFound lastRowOnColumn1 = LastRow(wksTarget, col) Set localRange = wksTarget.Range(wksTarget.Cells(1, col), wksTarget.Cells(lastRowOnColumn1, col)) For Each myCell In localRange If lookForPart Then If UCase(textTarget) = UCase(Left(myCell, Len(textTarget))) Then If valuesFound = 1 Then LocateValueRow = myCell.Row If lookUpToBottom Then Exit Function Else Decrement valuesFound End If End If Else If UCase(textTarget) = UCase(Trim(myCell)) Then If valuesFound = 1 Then LocateValueRow = myCell.Row If lookUpToBottom Then Exit Function Else Decrement valuesFound End If End If End If Next myCell End Function Public Function LocateValueCol(ByVal textTarget As String, _ ByRef wksTarget As Worksheet, _ Optional rowNeeded As Long = 1, _ Optional moreValuesFound As Long = 1, _ Optional lookForPart = False, _ Optional lookUpToBottom = True) As Long Dim valuesFound As Long Dim localRange As Range Dim myCell As Range LocateValueCol = GENERAL_NUMBERS.NF valuesFound = moreValuesFound Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.count)) For Each myCell In localRange If lookForPart Then If UCase(textTarget) = UCase(Left(myCell, Len(textTarget))) Then If valuesFound = 1 Then LocateValueCol = myCell.Column If lookUpToBottom Then Exit Function Else Decrement valuesFound End If End If Else If UCase(textTarget) = UCase(Trim(myCell)) Then If valuesFound = 1 Then LocateValueCol = myCell.Column If lookUpToBottom Then Exit Function Else Decrement valuesFound End If End If End If Next myCell End Function Public Function GetColumnSequence(tbl As Worksheet, tableName As String, columnName As String) As Long Dim myCell As Range Dim result As Long result = 1 For Each myCell In ThisWorkbook.Worksheets(tbl.Name).Range(tableName & "[#Headers]").Cells If UCase(Trim(myCell)) = UCase(Trim(columnName)) Then GetColumnSequence = result Exit Function Else result = result + 1 End If Next GetColumnSequence = -1 End Function Private Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1) valueToIncrement = valueToIncrement + incrementWith End Sub Private Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1) valueToDecrement = valueToDecrement - decrementWith End Sub Public Function CountSubstringsInRow(wks As Worksheet, substring As String, Optional myRow As Long = 1) Dim myLastCol As Long myLastCol = LastColumn(wks, myRow) Dim result As Long Dim myCell As Range With wks For Each myCell In .Range(.Cells(myRow, 1), .Cells(myRow, myLastCol)) If InStr(1, myCell.Text, substring, vbTextCompare) Then result = result + 1 End If Next End With CountSubstringsInRow = result End Function 'LastRow Last Row Formula =IFERROR(LOOKUP(2,1/(NOT(ISBLANK(A:A))),ROW(A:A)),0) 'LastColumn Last Column Formula =IFERROR(LOOKUP(2,1/(NOT(ISBLANK(1:1))),COLUMN(1:1)),0) 'Last Row Value of Column A =LOOKUP(2,1/(NOT(ISBLANK(A:A))),A:A) 'Last Column Value of the first row =LOOKUP(2,1/(NOT(ISBLANK(1:1))),1:1) ================================================ FILE: Boilerplate/Lock.vb ================================================ 'lock cells, lock ranges, lock cells with formulas Sub ProtectCellsWithFormulas() Dim wks As Worksheet Dim myCell As Range For Each wks In ThisWorkbook.Worksheets With wks If .Name = tblForwinCrest.Name Or .Name = tblForwinCrestPrefilled.Name Then .Unprotect "v" For Each myCell In wks.Range("A1:R102").Cells If myCell.MergeArea.Cells.Count = 1 Then If myCell.HasFormula Then myCell.Locked = True Else myCell.Locked = False End If End If Next myCell .EnableOutlining = True .Protect "v", contents:=True, userinterfaceonly:=True End If End With Next wks End Sub ================================================ FILE: Boilerplate/MinAndMax.vb ================================================ Function Min(ParamArray values() As Variant) As Variant Dim minValue As Variant, Value As Variant minValue = values(0) For Each Value In values If Value < minValue Then minValue = Value Next Min = minValue End Function Function Max(ParamArray values() As Variant) As Variant Dim maxValue As Variant, Value As Variant maxValue = values(0) For Each Value In values If Value > minValue Then maxValue = Value Next Max = maxValue End Function ================================================ FILE: Boilerplate/NamedRanges.vb ================================================ Option Explicit 'Application.Run "Personal.xlsb!DeleteName", "NAME_HERE" Public Sub DeleteName(sName As String) On Error GoTo DeleteName_Error ActiveWorkbook.Names(sName).Delete Debug.Print sName & " is deleted!" On Error GoTo 0 Exit Sub DeleteName_Error: Debug.Print sName & " not present or some error" On Error GoTo 0 End Sub Public Sub RemoveNamedRanges() Dim nName As Name Dim strNameReserved As String On Error Resume Next strNameReserved = "set_in_production" For Each nName In Names If nName.Name <> strNameReserved And Left(nName.Name, 1) <> "_" Then Debug.Print nName.Name nName.Delete End If Next nName On Error GoTo 0 End Sub Sub get_names_of_cells() Dim cell As Range On Error Resume Next For Each cell In Selection cell = cell.Name.Name Next cell On Error GoTo 0 End Sub Sub set_names_of_cells() Dim sample_range As Range Dim cell As Range Set sample_range = Selection For Each cell In sample_range If Not IsEmpty(cell) Then cell.Name = cell.Text cell.Clear End If Next cell End Sub Public Sub RemoveNamedRangesWithErrors() Dim nName As name Dim strNameReserved As String On Error Resume Next For Each nName In Names Debug.Print nName.RefersTo If Left(nName.RefersTo, 2) = "=#" Then Debug.Print nName.RefersTo 'nName.Delete End If Next nName On Error GoTo 0 End Sub Sub UnhideAllNames() Dim tempName As Name For Each tempName In Names 'Debug.Print tempname.Name tempName.Visible = False Next tempName End Sub ================================================ FILE: Boilerplate/NotepadExport.vb ================================================ ' export to notepad export txt export string string to txt string to notepad Option Explicit Public STR_ERROR_REPORT As String Sub CreateLogFile(Optional str_print As String) On Error GoTo CreateLogFile_Error Dim fs As Object Dim obj_text As Object Dim str_filename As String Dim str_new_file As String Dim str_shell As String str_new_file = "\tests_info" str_filename = ThisWorkbook.Path & str_new_file & codify_time(True) If Dir(ThisWorkbook.Path & str_new_file, vbDirectory) = vbNullString Then MkDir ThisWorkbook.Path & str_new_file Set fs = CreateObject("Scripting.FileSystemObject") Set obj_text = fs.CreateTextFile(str_filename, True) If Len(STR_ERROR_REPORT) > 1 Then obj_text.writeline (STR_ERROR_REPORT) Else obj_text.writeline (str_print) End If obj_text.Close str_shell = "C:\WINDOWS\notepad.exe " str_shell = str_shell & str_filename Call Shell(str_shell) On Error GoTo 0 Exit Sub CreateLogFile_Error: Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure CreateLogFile of Sub mod_TDD_Export" End Sub Public Function codify_time(Optional b_make_str As Boolean = False) As String On Error GoTo codify_Error Dim dbl_01 As Variant Dim dbl_02 As Variant Dim dbl_now As Double dbl_now = Round(Now(), 8) dbl_01 = Split(CStr(dbl_now), ",")(0) dbl_02 = Split(CStr(dbl_now), ",")(1) codify_time = Hex(dbl_01) & "_" & Hex(dbl_02) If b_make_str Then codify_time = "\" & codify_time & ".txt" On Error GoTo 0 Exit Function codify_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure codify of Function TDD_Export" End Function ================================================ FILE: Boilerplate/OnStartOnEnd.vb ================================================ Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.AskToUpdateLinks = True Application.DisplayAlerts = True ActiveWindow.View = xlNormalView Application.StatusBar = False Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False End Sub Public Sub OnStart() Application.ScreenUpdating = False Application.EnableEvents = False Application.AskToUpdateLinks = False Application.DisplayAlerts = False ActiveWindow.View = xlNormalView Application.StatusBar = False Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False End Sub ================================================ FILE: Boilerplate/RegEx.vb ================================================ Option Explicit Public Sub RegExExample() Dim strString As String Dim lngCounter As Long Dim objRegex As Object Dim arrWords As Variant 'RegEx with late binding Set objRegex = CreateObject("VBScript.RegExp") strString = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua." arrWords = Split(strString) objRegex.Pattern = "or" For lngCounter = LBound(arrWords) To UBound(arrWords) If objRegex.test(arrWords(lngCounter)) Then Debug.Print arrWords(lngCounter) End If Next lngCounter End Sub '=============================================================================== '=============================================================================== 'removes anything that is not a digit or word from the string=================== Public Function removeInvisibleThings(s As String) As String Dim regEx As Object Dim inputMatches As Object Dim regExString As String Set regEx = CreateObject("VBScript.RegExp") With regEx .pattern = "[^a-zA-Z0-9]" .IgnoreCase = True .Global = True Set inputMatches = .Execute(s) If regEx.test(s) Then removeInvisibleThings = .Replace(s, vbNullString) Else removeInvisibleThings = s End If End With End Function Public Sub TestMe() Debug.Print removeInvisibleThings("aa1 Abc 67 ( *^ 45 ") Debug.Print removeInvisibleThings("aa1 ???!") Debug.Print removeInvisibleThings(" aa1 Abc 1267 ( *^ 45 ") End Sub '=============================================================================== '=============================================================================== '=============================================================================== Public Function findTheSubString(wholeString As String, subString As String) As String Dim regEx As Object Dim inputMatches As Object Dim regExString As String Set regEx = CreateObject("VBScript.RegExp") With regEx .Pattern = Split(subString, "*")(0) & "[\s\S]*" & Split(subString, "*")(1) .IgnoreCase = True .Global = True Set inputMatches = .Execute(wholeString) If regEx.test(wholeString) Then findTheSubString = inputMatches(0) Else findTheSubString = "Not Found!" End If End With End Function '=============================================================================== '=============================================================================== '=============================================================================== ================================================ FILE: Boilerplate/StringsAlgorithms.vb ================================================ Public Function StringBetween2Strings(ByVal myText As String, _ ByVal lookBefore As String, _ ByVal repetition As Long, _ Optional ByVal lookAfter As String = " 1 i = InStr(i, myText, lookBefore, vbTextCompare) myText = Right(myText, Len(myText) - i) repetition = repetition - 1 Wend startPosition = InStr(1, myText, lookBefore) + Len(lookBefore) endPosition = InStr(startPosition, myText, lookAfter, vbTextCompare) StringBetween2Strings = Mid(myText, startPosition, endPosition - startPosition) Exit Function StringBetween2Strings_Error: StringBetween2Strings = -1 End Function Sub TestingLocateXmlData() Dim xmlA As String xmlA = "1PeterThe KeeperPeshoPartan199412IvanMitovGoshoGoshan18892/FootballInfo>" Debug.Print StringBetween2Strings(xmlA, "", 1) 'Peter Debug.Print StringBetween2Strings(xmlA, "", 1) 'The Keeper Debug.Print StringBetween2Strings(xmlA, "", 1) '1994 Debug.Print StringBetween2Strings(xmlA, "", 2) '1889 End Sub ================================================ FILE: Boilerplate/Timer.vb ================================================ Sub StartingTimer(ByRef myTime As Double) Debug.Print "Strating at:" Debug.Print Time myTime = Timer End Sub Sub EndingTimer(ByRef myTime As Double) Debug.Print "Ending at:" Debug.Print Time Debug.Print "Total time:" Debug.Print Format((Timer - myTime) / 86400, "hh:mm:ss") End Sub Sub TestAll() Dim myTime As Double StartingTimer myTime Stop 'PUT THE STUFF HERE! EndingTimer myTime End Sub ================================================ FILE: Boilerplate/VariousDatesFirstDay.vb ================================================ Option Explicit Public Function GetLastDayOfMonth(ByVal myDate As Date) As Date GetLastDayOfMonth = DateSerial(Year(myDate), Month(myDate) + 1, 0) End Function Public Function GetFirstDayOfMonth(ByVal myDate As Date) As Date GetFirstDayOfMonth = DateSerial(Year(myDate), Month(myDate), 1) End Function Public Function AddMonths(ByVal myDate As Date, ByVal lngMonth As Long) As Date AddMonths = GetLastDayOfMonth(DateAdd("m", lngMonth, myDate)) End Function Public Function AddMonthsAndGetFirstDate(ByVal my_date As Date, ByVal lngMonth As Long) As Date AddMonthsAndGetFirstDate = GetFirstDayOfMonth(DateAdd("m", lngMonth, my_date)) End Function Public Function DateDiffInMonths(a As Date, b As Date) As Long DateDiffInMonths = DateDiff("m", a, b) End Function Sub TestMe() Debug.Print GetLastDayOfMonth(DateSerial(2020, 2, 22)) Debug.Print GetLastDayOfMonth(DateSerial(2021, 2, 22)) Debug.Print GetFirstDayOfMonth(DateSerial(2021, 2, 22)) Debug.Print AddMonths(DateSerial(2020, 2, 23), 3) Debug.Print AddMonthsAndGetFirstDate(DateSerial(2020, 2, 23), 3) Debug.Print DateDiffInMonths(DateSerial(1988, 8, 18), DateSerial(1998, 10, 18)) End Sub ================================================ FILE: Boilerplate/WorksheetToCSV ================================================ Option Explicit Public Const CSV_NAME As String = "CSV_FILE" Public Const MY_STEP As Long = 5 Public Const WKS_TO_KEEP As String = "Tabelle1" 'split worksheet 'worksheet to csv 'worksheets to csv 'convert to csv 'https://www.vitoshacademy.com/vba-split-worksheet-to-worksheets-save-excel-worksheets-to-csv/ Function WksToKeep() As Worksheet Set WksToKeep = ThisWorkbook.Worksheets(WKS_TO_KEEP) End Function Sub SplitMe() OnStart Dim myLastRow As Long: myLastRow = LastRow(WksToKeep) Dim myCell As Range, i As Long For i = 1 To myLastRow Step MY_STEP With WksToKeep Dim newWks As Worksheet Set newWks = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)) newWks.Name = i newWks.Rows(1).Value = .Rows(1).Value Dim ii As Long For ii = 2 To MY_STEP + 1 With newWks newWks.Rows(ii).Value = WksToKeep.Rows(i + ii - 1).Value End With Next End With Next OnEnd End Sub Public Sub DeleteAllButOne() Dim wks As Worksheet OnStart For Each wks In ThisWorkbook.Worksheets If wks.Name <> WKS_TO_KEEP Then wks.Delete End If Next wks OnEnd End Sub Public Sub MakeMeACSV() Dim myNewWorkbook As Workbook OnStart Dim myWorksheet As Worksheet For Each myWorksheet In ThisWorkbook.Worksheets If myWorksheet.Name <> WKS_TO_KEEP Then Set myNewWorkbook = Workbooks.Add myWorksheet.Copy myNewWorkbook.Sheets(1) myNewWorkbook.Worksheets(WKS_TO_KEEP).Delete Dim myFileName As String myFileName = ThisWorkbook.Path & "\" myFileName = myFileName & CSV_NAME & Format(Date, "YYYYMMDD") & "_" & Format(Now(), "hhnnss") & ".csv" myNewWorkbook.Worksheets(1).Columns(1).Delete If myNewWorkbook.Worksheets(1).Cells(2, 1).Value = "" Then myNewWorkbook.Worksheets(1).Rows(1).Delete End If Debug.Print myNewWorkbook.Path myNewWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlCSV, local:=True myNewWorkbook.Close False End If Next OnEnd End Sub Sub Main() SplitMe MakeMeACSV End Sub Public Sub OnStart() Application.DisplayAlerts = False Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False End Sub Public Sub OnEnd() Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False End Sub Public Function LastColumn(ws As Worksheet, Optional rowToCheck As Long = 1) As Long LastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column End Function Public Function LastRow(ws As Worksheet, Optional columnToCheck As Long = 1) As Long LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row End Function ================================================ FILE: Boilerplate/readme.md ================================================ [The project migrated here.](https://github.com/vboilerplate) **But** it will return back to its place (here), as I am not updating it there 🌞🥈🚛 ================================================ FILE: ExcelTdd/InlineRunner.vb ================================================ Option Explicit Option Private Module Public Sub RunSuite(specs As SpecSuite, _ Optional ShowFailureDetails As Boolean = True, _ Optional ShowPassed As Boolean = False, _ Optional ShowSuiteDetails As Boolean = False) Dim SuiteCol As New Collection SuiteCol.Add specs RunSuites SuiteCol, ShowFailureDetails, ShowPassed, ShowSuiteDetails End Sub Public Sub RunSuites(SuiteCol As Collection, _ Optional ShowFailureDetails As Boolean = True, _ Optional ShowPassed As Boolean = False, _ Optional ShowSuiteDetails As Boolean = True) Dim Suite As SpecSuite Dim Spec As SpecDefinition Dim TotalCount As Long Dim FailedSpecs As Long Dim PendingSpecs As Long Dim ShowingResults As Boolean Dim Indentation As String For Each Suite In SuiteCol If Not Suite Is Nothing Then TotalCount = TotalCount + Suite.SpecsCol.Count For Each Spec In Suite.SpecsCol If Spec.result = SpecResult.FAIL Then FailedSpecs = FailedSpecs + 1 ElseIf Spec.result = SpecResult.Pending Then PendingSpecs = PendingSpecs + 1 End If Next Spec End If Next Suite Debug.Print "= " & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & " = " & GetDateAndTime & " =========================" & vbCrLf str_error_report = str_error_report & "= " & SummaryMessage(TotalCount, FailedSpecs, PendingSpecs) & " = " & GetDateAndTime & " =========================" For Each Suite In SuiteCol If Not Suite Is Nothing Then If ShowSuiteDetails Then Debug.Print SuiteMessage(Suite) Indentation = " " ShowingResults = True Else Indentation = "" End If For Each Spec In Suite.SpecsCol If Spec.result = SpecResult.FAIL Then Debug.Print Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation) str_error_report = str_error_report & vbCrLf & Indentation & FailureMessage(Spec, ShowFailureDetails, Indentation) ShowingResults = True ElseIf Spec.result = SpecResult.Pending Then Debug.Print Indentation & PendingMessage(Spec) str_error_report = str_error_report & vbCrLf & Indentation & PendingMessage(Spec) ShowingResults = True ElseIf ShowPassed Then Debug.Print Indentation & PassingMessage(Spec) str_error_report = str_error_report & vbCrLf & Indentation & PassingMessage(Spec) ShowingResults = True End If Next Spec End If Next Suite If ShowingResults Then Debug.Print "===" str_error_report = str_error_report & vbCrLf & "===" & vbCrLf End If End Sub Private Function SummaryMessage(TotalCount As Long, FailedSpecs As Long, PendingSpecs As Long) As String If FailedSpecs = 0 Then SummaryMessage = "PASS (" & TotalCount - PendingSpecs & " of " & TotalCount & " passed" Else SummaryMessage = "FAIL (" & FailedSpecs & " of " & TotalCount & " failed" End If If PendingSpecs = 0 Then SummaryMessage = SummaryMessage & ")" Else SummaryMessage = SummaryMessage & ", " & PendingSpecs & " pending)" End If End Function Private Function FailureMessage(Spec As SpecDefinition, ShowFailureDetails As Boolean, Indentation As String) As String Dim FailedExpectation As SpecExpectation Dim i As Long FailureMessage = ResultMessage(Spec, "X") If ShowFailureDetails Then FailureMessage = FailureMessage & vbNewLine For Each FailedExpectation In Spec.FailedExpectations FailureMessage = FailureMessage & Indentation & " " & FailedExpectation.FailureMessage If i + 1 <> Spec.FailedExpectations.Count Then FailureMessage = FailureMessage & vbNewLine i = i + 1 Next FailedExpectation End If End Function Private Function PendingMessage(Spec As SpecDefinition) As String PendingMessage = ResultMessage(Spec, ".") End Function Private Function PassingMessage(Spec As SpecDefinition) As String PassingMessage = ResultMessage(Spec, "+") End Function Private Function ResultMessage(Spec As SpecDefinition, Symbol As String) As String ResultMessage = Symbol & " " If Spec.ID <> "" Then ResultMessage = ResultMessage & Spec.ID & ": " End If ResultMessage = ResultMessage & Spec.Description End Function Private Function SuiteMessage(Suite As SpecSuite) As String Dim HasFailures As Boolean Dim Spec As SpecDefinition For Each Spec In Suite.SpecsCol If Spec.result = SpecResult.FAIL Then HasFailures = True Exit For End If Next Spec If HasFailures Then SuiteMessage = "X " Else SuiteMessage = "+ " End If If Suite.Description <> "" Then SuiteMessage = SuiteMessage & Suite.Description Else SuiteMessage = SuiteMessage & Suite.SpecsCol.Count & " specs" End If End Function ================================================ FILE: ExcelTdd/MakeValuesSelection.vb ================================================ '--------------------------------------------------------------------------------------- ' Method : MakeAllValues ' Author : v.doynov ' Date : 07.11.2016 ' Purpose: Select the range, for which you want the TDD code. ' Make sure that you can compile!!! (CreateLogFile and change_commas) '--------------------------------------------------------------------------------------- Public Sub MakeAllValues() Dim my_cell As Range Dim l_counter As Long Dim str As String Dim str_result As String STR_ERROR_REPORT = "" For Each my_cell In Selection Call Increment(l_counter) str = vbTab & "my_arr(" & l_counter & ")= " If Len(my_cell) > 0 Then If IsDate(my_cell) Then str = str & "CDate(""" & my_cell & """)" Else If Not IsNumeric(my_cell) Then str = str & """" & my_cell & """" Else str = str & change_commas(my_cell.value) End If End If Else If my_cell.HasFormula Then str = str & """""" Else str = str & 0 End If End If If Len(str_result) = 0 Then str_result = str Else str_result = str_result & vbCrLf & str End If Next my_cell Debug.Print str_result Call CreateLogFile(str_result) End Sub ================================================ FILE: ExcelTdd/README.md ================================================ Excel-TDD: Excel Testing Library ================================ In general, the library is taken from here: https://github.com/VBA-tools/VBA-TDD I have decided not to fork, because its easier for me to do so. I have updated a few points, making it more suitable for my purposes: - adding a Notepad file with information for the failures. This information is concatenated in STR_ERROR_REPORT. - counter of the tests in real time - checker whether an array is assigned This is what we get in the immediate window: **Test report from v.doynov START: 07-07-2017 22:14:38 999 expected.** **= PASS (2 of 2 passed) = 07-07-2017 22:14:38 =========================** **Tests:2** **Tests expected: 999 Total Tests: 2 END: 07-07-2017 22:14:38** This is the original Readme from the source: ======= Bring the reliability of other programming realms to VBA with Test-Driven Development (TDD) for VBA on Windows and Mac. Quick example: ```vb Function Specs() As SpecSuite Set Specs = New SpecSuite Specs.Description = "Add" ' Report results to the Immediate Window ' (ctrl + g or View > Immediate Window) Dim Reporter As New ImmediateReporter Reporter.ListenTo Specs ' Describe the desired behavior With Specs.It("should add two numbers") ' Test the desired behavior .Expect(Add(2, 2)).ToEqual 4 .Expect(Add(3, -1)).ToEqual 2 .Expect(Add(-1, -2)).ToEqual -3 End With With Specs.It("should add any number of numbers") .Expect(Add(1, 2, 3)).ToEqual 6 .Expect(Add(1, 2, 3, 4)).ToEqual 10 End With End Sub Public Function Add(ParamArray Values() As Variant) As Double Dim i As Integer Add = 0 For i = LBound(Values) To UBound(Values) Add = Add + Values(i) Next i End Function ' Immediate Window: ' ' === Add === ' + should add two numbers ' + should add any number of numbers ' = PASS (2 of 2 passed) = ``` For details of the process of reaching this example, see the [TDD Example](https://github.com/VBA-tools/VBA-TDD/wiki/TDD-Example) ### Advanced Example For an advanced example of what is possible with VBA-TDD, check out the [specs for VBA-Web](https://github.com/VBA-tools/VBA-Web/tree/master/specs) ### Getting Started 1. Download the [latest release (v2.0.0-beta)](https://github.com/VBA-tools/VBA-TDD/releases) 2. Add `src/SpecSuite.cls`, `src/SpecDefinition.cls`, `src/SpecExpectation.cls`, add `src/ImmediateReporter.cls` to your project 3. If you're starting from scratch with Excel, you can use `VBA-TDD - Blank.xlsm` ### It and Expect `It` is how you describe desired behavior and once a collection of specs is written, it should read like a list of requirements. ```vb With Specs.It("should allow user to continue if they are authorized and up-to-date") ' ... End With With Specs.It("should show an X when the user rolls a strike") ' ... End With ``` `Expect` is how you test desired behavior ```vb With Specs.It("should check values") .Expect(2 + 2).ToEqual 4 .Expect(2 + 2).ToNotEqual 5 .Expect(2 + 2).ToBeLessThan 7 .Expect(2 + 2).ToBeLT 6 .Expect(2 + 2).ToBeLessThanOrEqualTo 5 .Expect(2 + 2).ToBeLTE 4 .Expect(2 + 2).ToBeGreaterThan 1 .Expect(2 + 2).ToBeGT 2 .Expect(2 + 2).ToBeGreaterThanOrEqualTo 3 .Expect(2 + 2).ToBeGTE 4 .Expect(2 + 2).ToBeCloseTo 3.9, 0 End With With Specs.It("should check Nothing, Empty, Missing, and Null") .Expect(Nothing).ToBeNothing .Expect(Empty).ToBeEmpty .Expect().ToBeMissing .Expect(Null).ToBeNull ' `ToBeUndefined` checks if it's Nothing or Empty or Missing or Null .Expect(Nothing).ToBeUndefined .Expect(Empty).ToBeUndefined .Expect().ToBeUndefined .Expect(Null).ToBeUndefined ' Classes are undefined until they are instantiated Dim Sheet As Worksheet .Expect(Sheet).ToBeNothing .Expect("Howdy!").ToNotBeUndefined .Expect(4).ToNotBeUndefined Set Sheet = ThisWorkbook.Sheets(1) .Expect(Sheet).ToNotBeUndefined End With With Specs.It("should test complex things") .Expect(ThisWorkbook.Sheets("Hidden").Visible).ToNotEqual XlSheetVisibility.xlSheetVisible .Expect(ThisWorkbook.Sheets("Main").Cells(1, 1).Interior.Color).ToEqual RGB(255, 0, 0) End With ``` ### ImmediateReporter With your specs defined, the easiest way to display the test results is with `ImmediateReporter`. This outputs results to the Immediate Window (`ctrl+g` or View > Immediate Window) and is useful for running your tests without leaving the VBA editor. ```vb Public Function Specs As SpecSuite Set Specs = New SpecSuite Specs.Description = "..." ' Create reporter and attach it to these specs Dim Reporter As New ImmediateReporter Reporter.ListenTo Specs ' -> Reporter will now output results as they are generated End Function ``` ### RunMatcher For VBA applications that support `Application.Run` (which is at least Windows Excel, Word, and Access), you can create custom expect functions with `RunMatcher`. ```vb Public Function Specs As SpecSuite Set Specs = New SpecSuite With Specs.It("should be within 1 and 100") .Expect(50).RunMatcher "ToBeWithin", "to be within", 1, 100 ' ^ Actual ' ^ Public Function to call ' ^ message for matcher ' ^ 0+ Args to pass to matcher End With End Function Public Function ToBeWithin(Actual As Variant, Args As Variant) As Variant If UBound(Args) - LBound(Args) < 1 Then ' Return string for specific failure message ToBeWithin = "Need to pass in upper-bound to ToBeWithin" Else If Actual >= Args(0) And Actual <= Args(1) Then ' Return true for pass ToBeWithin = True Else ' Return false for fail or custom failure message ToBeWithin = False End If End If End Function ``` To avoid compilation issues on unsupported applications, the compiler constant `EnableRunMatcher` in `SpecExpectation.cls` should be set to `False`. For more details, check out the [Wiki](https://github.com/VBA-tools/VBA-TDD/wiki) - Design based heavily on the [Jasmine](https://jasmine.github.io/) - Author: Tim Hall - License: MIT ================================================ FILE: ExcelTdd/SpecDefinition.vb ================================================ Private pExpectations As Collection Private pFailedExpectations As Collection Public Enum SpecResult PASS FAIL Pending End Enum Public Description As String Public ID As String Public Property Get Expectations() As Collection If pExpectations Is Nothing Then Set pExpectations = New Collection End If Set Expectations = pExpectations End Property Private Property Let Expectations(value As Collection) Set pExpectations = value End Property Public Property Get FailedExpectations() As Collection If pFailedExpectations Is Nothing Then Set pFailedExpectations = New Collection End If Set FailedExpectations = pFailedExpectations End Property Private Property Let FailedExpectations(value As Collection) Set pFailedExpectations = value End Property Public Function Expect(Optional value As Variant) As SpecExpectation Dim Exp As New SpecExpectation If VarType(value) = vbObject Then Set Exp.Actual = value Else Exp.Actual = value End If Me.Expectations.Add Exp Set Expect = Exp End Function Public Function result() As SpecResult Dim Exp As SpecExpectation ' Reset failed expectations FailedExpectations = New Collection ' If no expectations have been defined, return pending If Me.Expectations.Count < 1 Then result = Pending Else ' Loop through all expectations For Each Exp In Me.Expectations ' If expectation fails, store it If Exp.result = FAIL Then FailedExpectations.Add Exp End If Next Exp ' If no expectations failed, spec passes If Me.FailedExpectations.Count > 0 Then result = FAIL Else result = PASS End If End If End Function Public Function ResultName() As String Select Case Me.result Case PASS: ResultName = "Pass" Case FAIL: ResultName = "Fail" Case Pending: ResultName = "Pending" End Select End Function ================================================ FILE: ExcelTdd/SpecExpectation.vb ================================================ Public Enum ExpectResult PASS FAIL End Enum Public Actual As Variant Public Expected As Variant Public result As ExpectResult Public FailureMessage As String Public Sub ToEqual(Expected As Variant) check IsEqual(Me.Actual, Expected), "to equal", Expected:=Expected End Sub Public Sub ToNotEqual(Expected As Variant) check IsEqual(Me.Actual, Expected), "to not equal", Expected:=Expected, Inverse:=True End Sub Private Function IsEqual(Actual As Variant, Expected As Variant) As Variant Dim l_count As Long 'here added additional value If IsArray(Expected) Then If UBound(Expected) <> UBound(Actual) Then IsEqual = False: Exit Function For l_count = LBound(Expected) To UBound(Expected) If Not Expected(l_count) = Actual(l_count) Then IsEqual = False: Exit Function Next l_count IsEqual = True End If 'end of additional value If IsError(Actual) Or IsError(Expected) Then IsEqual = False ElseIf IsObject(Actual) Or IsObject(Expected) Then IsEqual = "Unsupported: Can't compare objects" ElseIf VarType(Actual) = vbDouble And VarType(Expected) = vbDouble Then IsEqual = IsCloseTo(Actual, Expected, 15) Else IsEqual = Actual = Expected End If End Function Public Sub ToBeDefined() Debug.Print "Excel-TDD: DEPRECATED, ToBeDefined() has been deprecated in favor of ToNotBeUndefined and will be removed in Excel-TDD v2.0.0" check IsUndefined(Me.Actual), "to be defined", Inverse:=True End Sub Public Sub ToBeUndefined() check IsUndefined(Me.Actual), "to be undefined" End Sub Public Sub ToNotBeUndefined() check IsUndefined(Me.Actual), "to not be undefined", Inverse:=True End Sub Private Function IsUndefined(Actual As Variant) As Variant IsUndefined = IsNothing(Actual) Or IsEmpty(Actual) Or IsNull(Actual) Or IsMissing(Actual) End Function Public Sub ToBeNothing() check IsNothing(Me.Actual), "to be nothing" End Sub Public Sub ToNotBeNothing() check IsNothing(Me.Actual), "to not be nothing", Inverse:=True End Sub Private Function IsNothing(Actual As Variant) As Variant If IsObject(Actual) Then If Actual Is Nothing Then IsNothing = True Else IsNothing = False End If Else IsNothing = False End If End Function Public Sub ToBeEmpty() check IsEmpty(Me.Actual), "to be empty" End Sub Public Sub ToNotBeEmpty() check IsEmpty(Me.Actual), "to not be empty", Inverse:=True End Sub Public Sub ToBeNull() check IsNull(Me.Actual), "to be null" End Sub Public Sub ToNotBeNull() check IsNull(Me.Actual), "to not be null", Inverse:=True End Sub Public Sub ToBeMissing() check IsMissing(Me.Actual), "to be missing" End Sub Public Sub ToNotBeMissing() check IsMissing(Me.Actual), "to not be missing", Inverse:=True End Sub Public Sub ToBeLessThan(Expected As Variant) check IsLT(Me.Actual, Expected), "to be less than", Expected:=Expected End Sub Public Sub ToBeLT(Expected As Variant) ToBeLessThan Expected End Sub Private Function IsLT(Actual As Variant, Expected As Variant) As Variant If IsError(Actual) Or IsError(Expected) Or Actual >= Expected Then IsLT = False Else IsLT = True End If End Function Public Sub ToBeLessThanOrEqualTo(Expected As Variant) check IsLTE(Me.Actual, Expected), "to be less than or equal to", Expected:=Expected End Sub Public Sub ToBeLTE(Expected As Variant) ToBeLessThanOrEqualTo Expected End Sub Private Function IsLTE(Actual As Variant, Expected As Variant) As Variant If IsError(Actual) Or IsError(Expected) Or Actual > Expected Then IsLTE = False Else IsLTE = True End If End Function Public Sub ToBeGreaterThan(Expected As Variant) check IsGT(Me.Actual, Expected), "to be greater than", Expected:=Expected End Sub Public Sub ToBeGT(Expected As Variant) ToBeGreaterThan Expected End Sub Private Function IsGT(Actual As Variant, Expected As Variant) As Variant If IsError(Actual) Or IsError(Expected) Or Actual <= Expected Then IsGT = False Else IsGT = True End If End Function Public Sub ToBeGreaterThanOrEqualTo(Expected As Variant) check IsGTE(Me.Actual, Expected), "to be greater than or equal to", Expected:=Expected End Sub Public Sub ToBeGTE(Expected As Variant) ToBeGreaterThanOrEqualTo Expected End Sub Private Function IsGTE(Actual As Variant, Expected As Variant) As Variant If IsError(Actual) Or IsError(Expected) Or Actual < Expected Then IsGTE = False Else IsGTE = True End If End Function Public Sub ToBeCloseTo(Expected As Variant, SignificantFigures As Long) check IsCloseTo(Me.Actual, Expected, SignificantFigures), "to be close to", Expected:=Expected End Sub Public Sub ToNotBeCloseTo(Expected As Variant, SignificantFigures As Long) check IsCloseTo(Me.Actual, Expected, SignificantFigures), "to be close to", Expected:=Expected, Inverse:=True End Sub Private Function IsCloseTo(Actual As Variant, Expected As Variant, SignificantFigures As Long) As Variant Dim ActualAsString As String Dim ExpectedAsString As String If SignificantFigures < 1 Or SignificantFigures > 15 Then IsCloseTo = "ToBeCloseTo/ToNotBeClose to can only compare from 1 to 15 significant figures""" ElseIf Not IsError(Actual) And Not IsError(Expected) Then ' Convert values to scientific notation strings and then compare strings If Actual > 1 Then ActualAsString = VBA.Format$(Actual, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e+0") Else ActualAsString = VBA.Format$(Actual, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e-0") End If If Expected > 1 Then ExpectedAsString = VBA.Format$(Expected, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e+0") Else ExpectedAsString = VBA.Format$(Expected, VBA.Left$("0.00000000000000", SignificantFigures + 1) & "e-0") End If IsCloseTo = ActualAsString = ExpectedAsString End If End Function Public Sub ToContain(Expected As Variant, Optional MatchCase As Boolean = True) If VarType(Me.Actual) = vbString Then Debug.Print "Excel-TDD: DEPRECATED ToContain has been changed to ToMatch in Excel-TDD v2.0.0" If MatchCase Then check Matches(Me.Actual, Expected), "to match", Expected:=Expected Else check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), "to match", Expected:=Expected End If Else check Contains(Me.Actual, Expected), "to contain", Expected:=Expected End If End Sub Public Sub ToNotContain(Expected As Variant, Optional MatchCase As Boolean = True) If VarType(Me.Actual) = vbString Then Debug.Print "Excel-TDD: DEPRECATED ToNotContain has been changed to ToMatch in Excel-TDD v2.0.0" If MatchCase Then check Matches(Me.Actual, Expected), "to not match", Expected:=Expected, Inverse:=True Else check Matches(VBA.UCase$(Me.Actual), VBA.UCase$(Expected)), "to not match", Expected:=Expected, Inverse:=True End If Else check Contains(Me.Actual, Expected), "to not contain", Expected:=Expected, Inverse:=True End If End Sub Private Function Contains(Actual As Variant, Expected As Variant) As Variant Dim i As Long If Not IsArray(Actual) Then Contains = "Error: Actual needs to be an Array or Collection for ToContain/ToNotContain" Else If TypeOf Actual Is Collection Then For i = 1 To Actual.Count If Actual.item(i) = Expected Then Contains = True Exit Function End If Next i Else For i = LBound(Actual) To UBound(Actual) If Actual(i) = Expected Then Contains = True Exit Function End If Next i End If End If End Function Public Sub ToMatch(Expected As Variant) check Matches(Me.Actual, Expected), "to match", Expected:=Expected End Sub Public Sub ToNotMatch(Expected As Variant) check Matches(Me.Actual, Expected), "to not match", Expected:=Expected, Inverse:=True End Sub Private Function Matches(Actual As Variant, Expected As Variant) As Variant If InStr(Actual, Expected) > 0 Then Matches = True Else Matches = False End If End Function Public Sub RunMatcher(Name As String, Message As String, ParamArray Arguments()) Dim Expected As String Dim i As Long Dim HasArguments As Boolean HasArguments = UBound(Arguments) >= 0 For i = LBound(Arguments) To UBound(Arguments) If Expected = "" Then Expected = GetStringForValue(Arguments(i)) ElseIf i = UBound(Arguments) Then If (UBound(Arguments) > 1) Then Expected = Expected & ", and " & GetStringForValue(Arguments(i)) Else Expected = Expected & " and " & GetStringForValue(Arguments(i)) End If Else Expected = Expected & ", " & GetStringForValue(Arguments(i)) End If Next i If HasArguments Then check Application.Run(Name, Me.Actual, Arguments), Message, Expected:=Expected Else check Application.Run(Name, Me.Actual), Message End If End Sub Private Sub check(result As Variant, Message As String, Optional Expected As Variant, Optional Inverse As Boolean = False) If Not IsMissing(Expected) Then If IsObject(Expected) Then Set Me.Expected = Expected Else Me.Expected = Expected End If End If If VarType(result) = vbString Then Fails CStr(result) Else If Inverse Then result = Not result End If If result Then Passes Else Fails CreateFailureMessage(Message, Expected) End If End If End Sub Private Sub Passes() Me.result = ExpectResult.PASS End Sub Private Sub Fails(Message As String) Me.result = ExpectResult.FAIL Me.FailureMessage = Message End Sub Private Function CreateFailureMessage(Message As String, Optional Expected As Variant) As String CreateFailureMessage = "Expected " & GetStringForValue(Me.Actual) & " " & Message If Not IsMissing(Expected) Then CreateFailureMessage = CreateFailureMessage & " " & GetStringForValue(Expected) End If End Function Private Function GetStringForValue(value As Variant) As String If IsObject(value) Then If value Is Nothing Then GetStringForValue = "(Nothing)" Else GetStringForValue = "(Object)" End If ElseIf IsArray(value) Then GetStringForValue = "(Array)" ElseIf IsEmpty(value) Then GetStringForValue = "(Empty)" ElseIf IsNull(value) Then GetStringForValue = "(Null)" ElseIf IsMissing(value) Then GetStringForValue = "(Missing)" Else GetStringForValue = CStr(value) End If If GetStringForValue = "" Then GetStringForValue = "(Undefined)" End If End Function Private Function IsArray(value As Variant) As Boolean If Not IsEmpty(value) Then If IsObject(value) Then If TypeOf value Is Collection Then IsArray = True End If ElseIf VarType(value) = vbArray Or VarType(value) = 8204 Then IsArray = True End If End If End Function ================================================ FILE: ExcelTdd/SpecSuite.vb ================================================ Option Explicit Private pSpecsCol As Collection Public Description As String Public BeforeEachCallback As String Public BeforeEachCallbackArgs As Variant Private pCounter As Long Public Property Get SpecsCol() As Collection If pSpecsCol Is Nothing Then Set pSpecsCol = New Collection Set SpecsCol = pSpecsCol End Property Public Property Let SpecsCol(value As Collection) Set pSpecsCol = value End Property Public Function It(Description As String, Optional SpecId As String = "") As SpecDefinition Dim Spec As New SpecDefinition pCounter = pCounter + 1 ExecuteBeforeEach Spec.Description = Description Spec.ID = SpecId Me.SpecsCol.Add Spec Set It = Spec End Function Public Function f_lng_number_tests() As Long f_lng_number_tests = pCounter End Function Public Sub TotalTests() Call Increment(lng_total_tests, Me.f_lng_number_tests) Debug.Print " Tests:" & pCounter & vbCrLf str_error_report = str_error_report & vbCrLf & " Tests:" & pCounter & vbCrLf End Sub Public Sub BeforeEach(Callback As String, ParamArray CallbackArgs() As Variant) Me.BeforeEachCallback = Callback Me.BeforeEachCallbackArgs = CallbackArgs End Sub Private Sub ExecuteBeforeEach() If Me.BeforeEachCallback <> vbNullString Then Dim HasArguments As Boolean If VarType(Me.BeforeEachCallbackArgs) = vbObject Then If Not Me.BeforeEachCallbackArgs Is Nothing Then HasArguments = True End If ElseIf IsArray(Me.BeforeEachCallbackArgs) Then If UBound(Me.BeforeEachCallbackArgs) >= 0 Then HasArguments = True End If End If If HasArguments Then Application.Run Me.BeforeEachCallback, Me.BeforeEachCallbackArgs Else Application.Run Me.BeforeEachCallback End If End If End Sub ================================================ FILE: ExcelTdd/TDD_example.vb ================================================ Public Sub Tdd_CA2() On Error Resume Next Dim specs As New SpecSuite Dim myArr As Variant Dim lngSize As Long: lngSize = 46 myArr = fnArr_CA0_002 For lngCounter = 0 To UBound(myArr) lngRow = lngCounter \ lngSize lngCol = lngCounter Mod lngSize specs.It("CA0_002_F86_Row" & lngRow + 1 & "_Col" & lngCol + 1).Expect(myArr(lngCounter + 1)).ToEqual tbl_calendar.[f86].Offset(lngRow, lngCol).value specs.It("MUST_FAIL_CA0_002_F86_Row" & lngRow + 1 & "_Col" & lngCol + 1).Expect(myArr(lngCounter + 1)).ToNotEqual tbl_calendar.[f86].Offset(lngRow, lngCol).value & "1" specs.It("MUST_FAIL_CA0_002_F86_Row" & lngRow + 1 & "_Col" & lngCol + 1).Expect(myArr(lngCounter + 1)).ToNotEqual tbl_calendar.[f86].Offset(lngRow, lngCol).value & "2" Next lngCounter InlineRunner.RunSuite specs Call specs.TotalTests On Error GoTo 0 End Sub Public Function fnArr_CA0_002() Dim my_arr As Variant ReDim my_arr(414) my_arr(1) = 1 my_arr(2) = 2 my_arr(413) = 8059.23 my_arr(414) = 0 fnArr_CA0_002 = my_arr End Function Public Sub MakeAllValues() Dim my_cell As Range Dim l_counter As Long Dim str As String Dim str_result As String STR_ERROR_REPORT = "" For Each my_cell In Selection Call Increment(l_counter) str = vbTab & "my_arr(" & l_counter & ")= " If Len(my_cell) > 0 Then If IsDate(my_cell) Then str = str & "CDate(""" & my_cell & """)" Else If Not IsNumeric(my_cell) Then str = str & """" & my_cell & """" Else str = str & change_commas(my_cell.value) End If End If Else If my_cell.HasFormula Then str = str & """""" Else str = str & 0 End If End If If Len(str_result) = 0 Then str_result = str Else str_result = str_result & vbCrLf & str End If Next my_cell Debug.Print str_result Call CreateLogFile(str_result) End Sub Public Sub MakeColorsAllValues() Dim myCell As Range Dim lngCounter As Long Dim str As String Dim strResult As String STR_ERROR_REPORT = "" For Each myCell In Selection Call Increment(lngCounter) str = vbTab & "my_arr(" & lngCounter & ")= " str = str & myCell.Interior.Color If Len(strResult) = 0 Then strResult = str Else strResult = strResult & vbCrLf & str End If Next myCell Debug.Print strResult Call CreateLogFile(strResult) End Sub Public Function codify_time(Optional b_make_str As Boolean = False) As String If [set_in_production] Then On Error GoTo codify_Error Dim dbl_01 As Variant Dim dbl_02 As Variant Dim dbl_now As Double dbl_now = Round(Now(), 8) dbl_01 = Split(CStr(dbl_now), ",")(0) dbl_02 = Split(CStr(dbl_now), ",")(1) codify_time = Hex(dbl_01) & "_" & Hex(dbl_02) If b_make_str Then codify_time = "\" & codify_time & ".txt" On Error GoTo 0 Exit Function codify_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure codify of Function TDD_Export" End Function ================================================ FILE: ExcelTdd/mod_NeutralSubsAndRoutines.vb ================================================ Option Explicit Public Sub Increment(ByRef value_to_increment, Optional l_plus As Double = 1) 'optional value type changed to_double value_to_increment = value_to_increment + l_plus End Sub Public Function GetDateAndTime() As String GetDateAndTime = Format(DateValue(Date), "dd-mm-yyyy") & " " & Time End Function Public Sub OnStart() Application.ScreenUpdating = False Application.EnableEvents = False Application.AskToUpdateLinks = False Application.DisplayAlerts = False Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False ActiveWindow.View = xlNormalView End Sub Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.AskToUpdateLinks = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False Application.StatusBar = False End Sub Public Function codify_time(Optional b_make_str As Boolean = False) As String If SET_IN_PRODUCTION Then On Error GoTo codify_Error Dim dbl_01 As Variant Dim dbl_02 As Variant Dim dbl_now As Double dbl_now = Round(Now(), 8) dbl_01 = Split(CStr(dbl_now), ",")(0) dbl_02 = Split(CStr(dbl_now), ",")(1) codify_time = Hex(dbl_01) & "_" & Hex(dbl_02) If b_make_str Then codify_time = "\" & codify_time & ".txt" On Error GoTo 0 Exit Function codify_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure codify of Function TDD_Export" End Function ================================================ FILE: ExcelTdd/mod_Notepad.vb ================================================ Option Explicit Public Sub CreateLogFile(Optional report As String) On Error GoTo CreateLogFile_Error WaitASecond Dim newFilePath As String newFilePath = "\reports" Dim fileName As String fileName = ThisWorkbook.Path & newFilePath & CodifyMyTime(True) If Dir(ThisWorkbook.Path & newFilePath, vbDirectory) = vbNullString Then MkDir ThisWorkbook.Path & newFilePath Dim fs As Object Set fs = CreateObject("Scripting.FileSystemObject") Dim notepad As Object Set notepad = fs.CreateTextFile(fileName, True) notepad.WriteLine report notepad.Close On Error GoTo 0 Exit Sub CreateLogFile_Error: Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure CreateLogFile of Sub mod_TDD_Export" End Sub Public Function CodifyMyTime(Optional makepath As Boolean = False) As String On Error GoTo codify_Error Dim timePart01 As Double Dim timePart02 As Double Dim timePartNow As Double timePartNow = Round(Now(), 8) timePart01 = Split(CStr(timePartNow), ".")(0) timePart02 = Split(CStr(timePartNow), ".")(1) CodifyMyTime = Format(Now, "YYYYMMMDD_HHNNSS") & "_" & Hex(timePart01) & "_" & Hex(timePart02) If makepath Then CodifyMyTime = "\" & CodifyMyTime & ".xml" On Error GoTo 0 Exit Function codify_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CodifyTime" End Function Public Sub WaitASecond() Application.Wait (Now + TimeValue("00:00:01")) End Sub ================================================ FILE: ExcelTdd/mod_PublicVariables.vb ================================================ Option Explicit Public STR_ERROR_REPORT As String Public LNG_TOTAL_TESTS As Long Public SET_IN_PRODUCTION As Boolean ================================================ FILE: ExcelTdd/mod_TddRoutines.vb ================================================ Option Explicit Option Private Module Public Sub Tdd() Dim lngTestsTotalExpected As Long ' Select Case MsgBox("The TDD is probably long.", vbYesNo, "Sure?") ' Case vbNo ' Exit Sub ' End Select SET_IN_PRODUCTION = False lngTestsTotalExpected = 999 'PLACEHOLDER_VALUE Debug.Print "Test report from " & Environ("Username") & vbCrLf & "START: " & GetDateAndTime & vbCrLf & _ lngTestsTotalExpected & " expected." & vbCrLf Call OnStart Worksheets(1).Select STR_ERROR_REPORT = "Test report from " & Environ("Username") & vbCrLf & "START: " & GetDateAndTime & vbCrLf & _ lngTestsTotalExpected & " expected." & vbCrLf & vbCrLf LNG_TOTAL_TESTS = 0 Call Tdd_01 STR_ERROR_REPORT = STR_ERROR_REPORT & vbCrLf & "Tests expected: " & lngTestsTotalExpected & vbCrLf & _ "Total Tests:" & LNG_TOTAL_TESTS & vbCrLf & "END: " & GetDateAndTime [SET_IN_PRODUCTION] = True Debug.Print "Tests expected: " & lngTestsTotalExpected Debug.Print "Total Tests:" & vbCrLf & LNG_TOTAL_TESTS & vbCrLf & "END: " & GetDateAndTime Call CreateLogFile Call OnEnd STR_ERROR_REPORT = "" End Sub ================================================ FILE: ExcelTdd/mod_TddRoutinesB.vb ================================================ Option Explicit Option Private Module Private lngCol As Long Private lngRow As Long Private lngCounter As Long Public Sub Tdd_01() On Error Resume Next Dim specs As New SpecSuite Dim lngValue As Long Dim dtValue As Date Dim strInitial As String Call OnStart specs.It("001", "Just A Test").Expect(2).ToEqual 1 + 1 specs.It("002", "Just A Test").Expect(2).ToNotEqual 1 + 1 + 2 InlineRunner.RunSuite specs Call specs.TotalTests Call OnEnd On Error GoTo 0 End Sub ================================================ FILE: Financial/BenfordModule.vb ================================================ Option Explicit Public Sub MainBenfordCheck(myRange As Range) Dim myCell As Range Dim benford As New BenfordModel For Each myCell In myRange If IsNumeric(myCell) Then benford.IncrementValue Abs(myCell.value) benford.IncrementCount End If Next myCell CreateLogFile benford.CreateBenfordLawReport End Sub Public Sub CreateLogFile(Optional report As String) On Error GoTo CreateLogFile_Error Dim newFilePath As String newFilePath = "\tests_info" Dim filename As String filename = ThisWorkbook.Path & newFilePath & CodifyTime(True) If Dir(ThisWorkbook.Path & newFilePath, vbDirectory) = vbNullString Then MkDir ThisWorkbook.Path & newFilePath Dim fs As Object Set fs = CreateObject("Scripting.FileSystemObject") Dim notepad As Object Set notepad = fs.CreateTextFile(filename, True) Dim header As String header = Now & vbCrLf & "Created by: " & Environ("USERNAME") notepad.WriteLine header notepad.WriteLine report notepad.Close Dim shellCommand As String shellCommand = "C:\WINDOWS\notepad.exe " shellCommand = shellCommand & filename Shell shellCommand On Error GoTo 0 Exit Sub CreateLogFile_Error: Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure CreateLogFile of Sub mod_TDD_Export" End Sub Public Function CodifyTime(Optional makePath As Boolean = False) As String On Error GoTo codify_Error Dim timePart01 As Double Dim timePart02 As Double Dim timePartNow As Double timePartNow = Round(Now(), 8) timePart01 = Split(CStr(timePartNow), ",")(0) timePart02 = Split(CStr(timePartNow), ",")(1) CodifyTime = Hex(timePart01) & "_" & Hex(timePart02) If makePath Then CodifyTime = "\" & CodifyTime & ".txt" On Error GoTo 0 Exit Function codify_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure codify of Function TDD_Export" End Function ================================================ FILE: Financial/BenfordModuleClass.vb ================================================ Option Explicit Private benfordCheckValues As Variant Private benfordCount As Long Sub Class_Initialize() Dim counter As Long ReDim benfordCheckValues(9) For counter = LBound(benfordCheckValues) To UBound(benfordCheckValues) benfordCheckValues(counter) = 0 Next counter End Sub Function InitialValuesBenford(val As Long) As Double '1 = "30,1%" '2 = "17,6%" '3 = "12,5%" '4 = " 9,7%" '5 = " 7,9%" '6 = " 6,7%" '7 = " 5,8%" '8 = " 5,1%" '9 = " 4,6%" InitialValuesBenford = Round(WorksheetFunction.Log10(1 + 1 / val), 3) End Function Function PercentageFixer(valToReturn As Double) As String If valToReturn > 0.1 Then PercentageFixer = Trim(Format(valToReturn, "##.0%")) ElseIf valToReturn = 0 Then PercentageFixer = " " & Format(valToReturn, "0.0%") Else PercentageFixer = " " & Format(valToReturn, "#.0%") End If End Function Function CreateBenfordLawReport() As String Dim line As String: line = "---------------------------------" On Error GoTo CreateBenfordLawReport_Error Dim counter As Long CreateBenfordLawReport = line & line & line & vbCrLf _ & line & line & line & vbCrLf _ & line & line & line & vbCrLf _ & "Benford's Law" & vbCrLf & "https://en.wikipedia.org/wiki/Benford%27s_law" & vbCrLf For counter = LBound(CheckValues) To UBound(CheckValues) If counter = 0 Then Dim header As String header = CreateBenfordLawReport & vbCrLf & "#" & vbTab & _ "-> " & "Val." & vbTab & "Real%" & vbTab & "Expected" CreateBenfordLawReport = header Else CreateBenfordLawReport = CreateBenfordLawReport & vbCrLf & counter & vbTab & _ "-> " & CheckValues(counter) & vbTab & _ PercentageFixer(Round(CheckValues(counter) / Me.Count, 3)) & vbTab & _ PercentageFixer(InitialValuesBenford(counter)) & vbTab & "|" End If If counter = 0 Or counter = 9 Then CreateBenfordLawReport = CreateBenfordLawReport & vbCrLf & line End If Next counter On Error GoTo 0 Exit Function CreateBenfordLawReport_Error: CreateBenfordLawReport = "Not enough data..." End Function Property Get CheckValues() As Variant CheckValues = benfordCheckValues End Property Property Get Count() As Long Count = benfordCount End Property Sub IncrementCount() benfordCount = benfordCount + 1 End Sub Sub IncrementValue(valToInput As Variant) Dim leftDigit As Variant leftDigit = Left(valToInput, 1) benfordCheckValues(leftDigit) = benfordCheckValues(leftDigit) + 1 End Sub ================================================ FILE: Financial/Binary.vb ================================================ Option Explicit Option Private Module Public Sub TestMe() Dim arrProducts As Variant Dim lngCounter As Long Dim lngValue As Long Dim strBinary As String Dim lngNumber As Long arrProducts = Array("AAA", "BBB", "CCC", "DDD", "EEE", "FFF", "GGG") '1, 2, 4, 8, 16, 32, 64 lngNumber = 65 '1+2+8+16 strBinary = StrReverse(LngToBinary(lngNumber)) For lngCounter = 1 To Len(strBinary) lngValue = Mid(strBinary, lngCounter, 1) If lngValue Then Debug.Print arrProducts(lngCounter - 1) End If Next lngCounter End Sub Function LngToBinary(ByVal n As Long) As String Dim k As Long LngToBinary = vbNullString If n < -2 ^ 15 Then LngToBinary = "0" n = n + 2 ^ 16 k = 2 ^ 14 ElseIf n < 0 Then LngToBinary = "1" n = n + 2 ^ 15 k = 2 ^ 14 Else k = 2 ^ 15 End If Do While k >= 1 LngToBinary = LngToBinary & Fix(n / k) n = n - k * Fix(n / k) k = k / 2 Loop End Function ================================================ FILE: Financial/ByReferenceByValue.vb ================================================ Option Explicit Public Sub TestMe() Dim var1, var2 Dim var3, var4 Dim var5, var6 var1 = Array(1, 1) var2 = Array(2, 1) var3 = Array(3, 1) var4 = Array(4, 1) var5 = Array(5, 1) var6 = Array(6, 1) increment1 (var1) increment2 (var2) increment1 var3 increment2 var4 var5 = increment1(var5) var6 = increment2(var6) Debug.Print var1(0) Debug.Print var2(0) Debug.Print var3(0) Debug.Print var4(0) Debug.Print var5(0) Debug.Print var6(0) End Sub Public Function increment1(ByVal testValue As Variant) As Variant testValue(0) = testValue(0) + 100 increment1 = testValue End Function Public Function increment2(ByRef testValue As Variant) As Variant testValue(0) = testValue(0) + 100 increment2 = testValue End Function 'Immediate Window ' 1 ' 2 ' 3 ' 104 ' 105 ' 106 ================================================ FILE: Financial/CalculateCostsWithInflation.vb ================================================ ' If we use the optional argument, -> calculate_total_month_value_with_inflation(100,1.06,37,2), ' this would return us the money for a month in the second period. -> 106 (100 + 1.06 inflation rate per year) Public Function calculate_total_month_value_with_inflation(ByVal dbl_per_month As Double, ByVal dbl_inflation As Double, ByVal int_total_length, Optional ByVal int_period As Long = 0) As Double Dim months_left As Long Dim years As Long Dim i_counter As Long Dim dbl_result As Double Dim previous_period As Double On Error GoTo calculate_total_month_value_with_inflation_Error years = int_total_length \ MONTHS_IN_YEAR months_left = int_total_length - MONTHS_IN_YEAR * years For i_counter = 0 To years - 1 If i_counter > 0 Then previous_period = dbl_result End If dbl_result = dbl_result + dbl_per_month * MONTHS_IN_YEAR * dbl_inflation ^ i_counter If int_period = i_counter + 1 Then calculate_total_month_value_with_inflation = (dbl_result - previous_period) / MONTHS_IN_YEAR Exit Function End If Next i_counter previous_period = dbl_result 'adding values for months_left dbl_result = dbl_result + dbl_per_month * months_left * dbl_inflation ^ i_counter 'checking if we need the values for the not filled months: If int_period > 0 Then If months_left = 0 Then calculate_total_month_value_with_inflation = dbl_per_month * dbl_inflation ^ (i_counter - 1) Exit Function Else calculate_total_month_value_with_inflation = (dbl_result - previous_period) / months_left Exit Function End If End If calculate_total_month_value_with_inflation = dbl_result On Error GoTo 0 Exit Function calculate_total_month_value_with_inflation_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure calculate_total_month_value_with_inflation of Modul mod_GeneralFunctions" End Function ================================================ FILE: Financial/DoubleCalculation.vb ================================================ 'double inaccuracy example example double inaccuracy floating point accuracy Sub TestMe() Dim a As Double: a = 20 Dim b As Double: b = 0.1 Cells.Clear Range("A1") = a - b Range("A2") = a + b Range("A3").Formula = "=A1-A2" Range("A4") = b * 2 * -1 Range("A5").Formula = "=A3=A4" End Sub Sub TestMe2() Dim a As Double: a = 20 Dim b As Double: b = 0.1 Cells.Clear Range("A1").Formula = "=" & a & "+0.1" Range("A2") = a Range("A3").Formula = "=A1-A2" Range("A4") = b Range("A5").Formula = "=A3=A4" End Sub ================================================ FILE: Financial/ExampleWithDoubles.vb ================================================ Option Explicit '--------------------------------------------------------------------------------------- ' Method : ErrorsNumber ' Author : v.doynov ' Date : 06.04.2017 ' Purpose: Model to see how excel calculates floating point numbers. '--------------------------------------------------------------------------------------- ' 0/2 + 0/4 + 0/8 + 1/16 + 1/32 +0/64 + 0/128 + 1/256 + 0/256 +1/512 +0/1024 + 0/2048 ' 0,099609375 '--------------------------------------------------------------------------------------- Public Sub ErrorsNumber() Const DIFF_DEFAULT = 0.1 ThisWorkbook.PrecisionAsDisplayed = False Dim lngEndNumber As Long: lngEndNumber = 30 Dim dblStarter As Double Dim dblEnder As Double Dim dblDiff As Double Dim lngCounter As Long Dim lngCounter2 As Long Dim lngRow As Long Dim dblResult As Double Dim lngCountErrors As Long Dim myCell As Range If lngEndNumber > 10000 Then Debug.Print lngEndNumber & "is too big, it takes too much time!": Exit Sub Call OnStart Cells.Clear For lngCounter = 0 To lngEndNumber dblDiff = DIFF_DEFAULT For lngCounter2 = 0 To 9 dblDiff = DIFF_DEFAULT * lngCounter2 lngRow = lngRow + 1 Set myCell = Cells(lngRow, 1) dblStarter = lngCounter + dblDiff dblEnder = lngCounter + dblDiff + DIFF_DEFAULT dblResult = dblStarter - dblEnder myCell = dblStarter myCell.Offset(0, 1) = dblEnder myCell.Offset(0, 2).FormulaR1C1 = "=RC[-1]-RC[-2]" myCell.Offset(0, 2).NumberFormat = "0.00000000000000000" myCell.Offset(0, 3).FormulaR1C1 = "=IF(RC[-1]=0.1,"""",""X"")" Next lngCounter2 If lngCounter Mod 100 = 0 Then Debug.Print lngCounter Next lngCounter With Range("E1") .FormulaR1C1 = "=COUNTIF(C[-1],""X"")/" & lngEndNumber * 10 .NumberFormat = "0.0000%" End With Columns.AutoFit Debug.Print "READY!" Call OnEnd End Sub Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.AskToUpdateLinks = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False Application.StatusBar = False End Sub Public Sub OnStart() Application.ScreenUpdating = False Application.EnableEvents = False Application.AskToUpdateLinks = False Application.DisplayAlerts = False Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False ActiveWindow.View = xlNormalView End Sub ================================================ FILE: Financial/MakeRedAndBlack.vb ================================================ '--------------------------------------------------------------------------------------- ' Module : mod_main ' Author : v.doynov ' Date : 27.01.2016 ' Purpose : To make the tool work, we need four lines of values. Rows 1,2 and Rows 4,5 ' We need to put values only on row 4, positive and negative. ' Then run the "main" procedure. '--------------------------------------------------------------------------------------- Option Explicit Public Const STARTING_FROM_COLUMN = 1 Public Const COLUMNS_NOT_TOUCHED = 0 Public current_cell As Range ' Public Sub Main() Dim my_cell As Range Dim l_col_len As Long: l_col_len = last_column(row_to_check:=4) Dim l_counter As Long Dim d_result As Double Dim d_result_ini As Double On Error GoTo main_Error Call OnStart tbl_output.Unprotect "toughpassword100" tbl_output.Rows(1).Clear tbl_output.Rows(2).Clear tbl_output.Rows(3).Clear tbl_output.Rows(5).Clear tbl_output.Rows(6).Clear 'Copy Range(Cells(1, 1), Cells(1, l_col_len)).Value = Range(Cells(4, 1), Cells(4, l_col_len)).Value 'Format Call MakeRedAndBlack(tbl_output.Cells(2, 1)) Call MakeRedAndBlack(tbl_output.Cells(5, 1)) Set my_cell = tbl_output.Cells(2, 1) my_cell.FormulaR1C1 = "=R[-1]C" my_cell.Offset(1, 0).Interior.Color = 5296274 Call MakeRedAndBlack(my_cell) Call MakeRedAndBlack(my_cell.Offset(-1, 0)) Set my_cell = tbl_output.Cells(5, 1) my_cell.FormulaR1C1 = "=R[-1]C" my_cell.Offset(1, 0).Interior.Color = 5296274 Call MakeRedAndBlack(my_cell) Call MakeRedAndBlack(my_cell.Offset(-1, 0)) For l_counter = 2 To l_col_len Set my_cell = tbl_output.Cells(2, l_counter) my_cell.Formula = "=R[-1]C+RC[-1]" my_cell.Offset(3, 0).Formula = "=R[-1]C+RC[-1]" my_cell.Offset(1, 0).Interior.Color = 5296274 my_cell.Offset(4, 0).Interior.Color = 5296274 Call MakeRedAndBlack(my_cell) Call MakeRedAndBlack(my_cell.Offset(-1, 0)) Call MakeRedAndBlack(my_cell.Offset(2, 0)) Call MakeRedAndBlack(my_cell.Offset(3, 0)) Next l_counter 'Action Call RedAndBlackRecalculation_main2(l_col_len, 2) 'Checks d_result = sum_range(tbl_output.Range(tbl_output.Cells(4, 1), tbl_output.Cells(4, l_col_len))) d_result_ini = sum_range(tbl_output.Range(tbl_output.Cells(1, 1), tbl_output.Cells(1, l_col_len))) If d_result > 0 Then [my_result] = d_result 'MsgBox "Sie haben keinen Gewinn. Ihre finanziellen Verlust beträgt " & d_result & " Euro.", vbInformation, "RedAndBlack" Else [my_result] = "" End If 'tbl_output.Protect "toughpassword100" If d_result <> d_result_ini Then MsgBox "Überprüfen Sie die Eingabe.", vbInformation, "RedAndBlack" End If tbl_output.Rows(2).EntireRow.Hidden = 1 tbl_output.Rows(5).EntireRow.Hidden = 1 Call OnEnd Set my_cell = Nothing On Error GoTo 0 Exit Sub main_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure main of Module mod_main" Call OnEnd End Sub Public Sub MakeRedAndBlack(ByRef my_range As Range) my_range.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" my_range.Font.Name = "Calibri" my_range.Font.Size = 11 'if we try to do it with parenthesis, then the zero values are not showing... 'my_range.NumberFormat = "$#,##0.00_);[Red]($#,##0.00);" End Sub '--------------------------------------------------------------------------------------- ' Procedure : RedAndBlackRecalculation ' Author : v.doynov ' Date : 07.08.2015 ' Purpose : Divides the row of "CashFlow vor Steuern" into red to the right and black ' to the left. Change "calendar_cols" and "current_row" to make it work. ' In order to call it use "call RedAndBlackRecalculation(27,84)". ' 84 is the middle line of the original 3 in PAKU. '--------------------------------------------------------------------------------------- ' Public Sub RedAndBlackRecalculation_main2(ByVal calendar_cols As Long, ByVal current_row As Long) Dim counter As Long Dim final_col_in_loop As Long Dim cell As Range Dim range_for_analysis As Range Dim holdback As Double Dim max_for_break_even As Double Dim cell_with_break_even As Range On Error GoTo RedAndBlackRecalculation_Error holdback = 0 'When used outside PAKU remove "tbl_output.Range" for the set With tbl_output Set range_for_analysis = .Range(.Cells(current_row, STARTING_FROM_COLUMN), .Cells(current_row, calendar_cols + COLUMNS_NOT_TOUCHED)) End With max_for_break_even = Application.WorksheetFunction.Max(range_for_analysis) For Each cell In range_for_analysis If cell.Value = max_for_break_even Then Set cell_with_break_even = cell Exit For End If Next cell final_col_in_loop = cell_with_break_even.Column + 1 current_row = current_row - 1 If cell_with_break_even.Column = 1 And cell_with_break_even <= 0 Then For counter = COLUMNS_NOT_TOUCHED + calendar_cols To cell_with_break_even.Column Step -1 With tbl_output Set current_cell = .Cells(current_row, counter) End With If current_cell > 0 Then holdback = holdback + current_cell current_cell = 0 Else current_cell = current_cell + holdback holdback = 0 End If 'we do it for a second time, 'in order to make it equal to zero, if 'it is not in the break even point If current_cell > 0 Then holdback = holdback + current_cell current_cell = 0 End If Next counter Else For counter = COLUMNS_NOT_TOUCHED + calendar_cols To final_col_in_loop Step -1 With tbl_output Set current_cell = .Cells(current_row, counter) End With If current_cell > 0 Then holdback = holdback + current_cell current_cell.Value = 0 Else current_cell = current_cell + holdback holdback = 0 End If 'we do it for a second time, 'in order to make it equal to zero, if 'it is not in the break even point If current_cell > 0 Then holdback = holdback + current_cell current_cell = 0 End If ' current_cell.Activate Next counter For counter = STARTING_FROM_COLUMN To cell_with_break_even.Column Step 1 With tbl_output Set current_cell = .Cells(current_row, counter) End With If current_cell < 0 Then holdback = holdback + current_cell current_cell = 0 Else If holdback + current_cell < 0 Then holdback = holdback + current_cell current_cell = 0 Else current_cell = current_cell + holdback holdback = 0 End If End If Next counter End If Set range_for_analysis = Nothing Set cell_with_break_even = Nothing Set cell = Nothing Set current_cell = Nothing On Error GoTo 0 Exit Sub RedAndBlackRecalculation_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure RedAndBlackRecalculation of Modul mod_RedAndBlackRecalculation" End Sub Function lastColumn(Optional sheetName As String, Optional rowToCheck As Long = 1) As Long Dim ws As Worksheet If sheetName = vbNullString Then Set ws = ActiveSheet Else Set ws = Worksheets(sheetName) End If lastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column End Function Public Function RGB2HTMLColor(B As Byte, G As Byte, R As Byte) As String Dim HexR As Variant, HexB As Variant, HexG As Variant Dim sTemp As String On Error GoTo ErrorHandler 'R HexR = Hex(R) If Len(HexR) < 2 Then HexR = "0" & HexR 'Get Green Hex HexG = Hex(G) If Len(HexG) < 2 Then HexG = "0" & HexG HexB = Hex(B) If Len(HexB) < 2 Then HexB = "0" & HexB RGB2HTMLColor = HexR & HexG & HexB Debug.Print "Enter RGB, without caring for the real colors, the function knows what it is doing." Debug.Print "IF 50D092 then &H0050D092&" Exit Function ErrorHandler: Debug.Print "RGB2HTMLColor was not successful" End Function Public Sub OnStart() Application.DisplayAlerts = False Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False End Sub Public Sub OnEnd() 'Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False End Sub Public Function sum_range(my_range As Range) As Double Dim cell As Range sum_range = 0 For Each cell In my_range sum_range = sum_range + cell.Value Next End Function ================================================ FILE: Financial/Readme.md ================================================ ## Financial
For the *SUMPRODUCT* formula in SumProductCountAndSum.xlsx.
It looks like this:
-------- =SUMPRODUCT((B2:B6=C2)*1)
+SUMPRODUCT((B8:B13=C8)*1)
+SUMPRODUCT((B16:B20=C16)*1)
-------- =SUMPRODUCT(((B2:B6=C2)*1)*(A2:A6=D2))
+SUMPRODUCT(((B8:B13=C8)*1)*(A8:A13=D8))
+SUMPRODUCT(((B16:B20=C16)*1)*(A16:A20=D16))
-------- ![Screenshot is here](https://image.ibb.co/nJ9WaF/Paint.png)
Array formula: Which value in array is found in a range? =INDEX(C1:C6,MATCH(TRUE,COUNTIF(D:D,C1:C6)>0,0)) ![Screenshot is here](http://image.ibb.co/nhsuZv/vlookup.png) ================================================ FILE: Financial/ScientificNotationExplanation.vb ================================================ Scientific Notation: ---------------- 0,000025 2,50E-05 2,5*(10^-5) ---------------- 0,00000000000025 2,50E-13 2,50(10^-13) ---------------- ================================================ FILE: Financial/VLookUpWithMultipleCriteria.vb ================================================ 'https://www.vitoshacademy.com/vba-vlookup-with-multiple-criteria-in-excel-without-excel-formula-but-with-vba/ Function GetLookupDataTriple(wks As Worksheet, tableName As String, lookIntoColumn As String, myArray As Variant) As Variant Dim lo As ListObject Set lo = wks.ListObjects(tableName) Dim i As Long For i = 2 To lo.ListColumns(myArray(0)).Range.Rows.Count If lo.ListColumns(myArray(0)).Range.Cells(RowIndex:=i) = myArray(1) Then If lo.ListColumns(myArray(2)).Range.Cells(RowIndex:=i) = myArray(3) Then If lo.ListColumns(myArray(4)).Range.Cells(RowIndex:=i) = myArray(5) Then GetLookupDataTriple = lo.ListColumns(lookIntoColumn).Range.Cells(RowIndex:=i) Exit Function End If End If End If Next i GetLookupDataTriple = -1 End Function Function GetLookupDataDouble(wks As Worksheet, tableName As String, lookIntoColumn As String, myArray As Variant) As Variant Dim lo As ListObject Set lo = wks.ListObjects(tableName) Dim i As Long For i = 2 To lo.ListColumns(myArray(0)).Range.Rows.Count If lo.ListColumns(myArray(0)).Range.Cells(RowIndex:=i) = myArray(1) Then If lo.ListColumns(myArray(2)).Range.Cells(RowIndex:=i) = myArray(3) Then GetLookupDataDouble = lo.ListColumns(lookIntoColumn).Range.Cells(RowIndex:=i) Exit Function End If End If Next i GetLookupDataDouble = -1 End Function ================================================ FILE: Formatting/Borders.vb ================================================ Option Explicit Sub MakeSelectionWithCells(my_range As Range) Dim l_line_style As Long: l_line_style = 1 Dim l_theme_color As Long: l_theme_color = 2 Dim d_tint_shade As Double: d_tint_shade = 0.349986266670736 Dim l_weight As Long: l_weight = 2 Dim l_counter As Long For l_counter = 7 To 12 Call MakeSelectionWithCells_Separated(l_line_style, l_theme_color, d_tint_shade, l_weight, l_counter, my_range) Next l_counter End Sub Public Sub MakeSelectionWithCells_Separated(l_line_style As Long, _ l_theme_color As Long, _ d_tint_shade As Double, _ l_weight As Long, _ l_counter As Long, _ my_range As Range) With my_range.Borders(l_counter) .LineStyle = l_line_style .ThemeColor = l_theme_color .TintAndShade = d_tint_shade .Weight = l_weight End With End Sub Public Sub BorderMe(myRange As Range) Dim cnt As Long For cnt = 7 To 10 '7 to 10 are the magic numbers for xlEdgeLeft etc With myRange.Borders(cnt) .LineStyle = xlContinuous .Weight = xlMedium End With Next End Sub Public Sub FixTableWithLines(tbl As Worksheet, Optional myStep As Long = 4, Optional myStart As Long = 2) OnStart Dim i As Long Dim myLastRow As Long: myLastRow = LastRow(tbl.Name) Dim myLastColumn As Long: myLastColumn = LastColumn(tbl.Name) Dim myRange As Range For i = myStart + myStep To myLastRow + myStep Step myStep With tbl Set myRange = .Range(.Cells(i, 1), .Cells(i, myLastColumn)) With myRange.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin End With End With Next i End Sub ================================================ FILE: Formatting/ColorSaturdayAndSunday.vb ================================================ Public Sub ColorSS() On Error GoTo ColorSS_Error 'Colors Saturdays and Sundays. Dim r_cell As Range Dim r_range As Range For Each r_cell In Selection If Weekday(r_cell.Value) = 1 Or Weekday(r_cell.Value) = 7 Then Set r_range = ActiveSheet.Range(Cells(4, r_cell.Column), Cells(340, r_cell.Column)) r_range.Interior.Color = 13434828 End If Next r_cell Set r_range = Nothing On Error GoTo 0 Exit Sub ColorSS_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ColorSS of Sub mod_play_with_me" End Sub ================================================ FILE: Formatting/Comments.vb ================================================ Public Sub AddCommentToSelection(myComment As String) Dim myCell As Range For Each myCell In Selection myCell.ClearComments myCell.AddComment myComment myCell.Comment.Visible = False myCell.Comment.Shape.ScaleWidth 4, msoFalse, msoScaleFromTopLeft myCell.Comment.Shape.ScaleHeight 2.26, msoFalse, msoScaleFromTopLeft Next myCell End Sub Public Sub DeleteCommentFromSelection() Dim myCell As Range For Each myCell In Selection myCell.ClearComments Next myCell End Sub Public Sub BeautifyComments(myCell As Range, commentText As String, Optional commentVisible As Boolean = False) myCell.ClearComments myCell.AddComment.Visible = commentVisible myCell.Comment.Text commentText With myCell.Comment.Shape .AutoShapeType = msoShapeRoundedRectangle .ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft .ScaleWidth 2, msoFalse, msoScaleFromTopLeft .TextFrame.Characters.Font.Name = "Tahoma" .TextFrame.Characters.Font.Size = 12 .TextFrame.Characters.Font.ColorIndex = 1 .Line.ForeColor.RGB = RGB(0, 0, 0) .Line.BackColor.RGB = RGB(255, 255, 255) .Fill.Visible = msoTrue .Fill.ForeColor.RGB = RGB(255, 204, 153) .Fill.OneColorGradient msoGradientDiagonalUp, 1, 0.25 .Line.DashStyle = msoLineLongDash .Shadow.Visible = msoFalse .Placement = xlMoveAndSize End With End Sub Public Sub MakeAllCommentsVisible() Dim myComment As Comment For Each myComment In Application.ActiveSheet.Comments myComment.Visible = False Next myComment End Sub ================================================ FILE: Formatting/Conditional Compilation Arguments.vb ================================================ 'Conditional Compilation Arguments in Access 'To set them this is the code: Application.SetOption "Conditional Compilation Arguments","A=4:B=10" 'To get them: Application.GetOption("Conditional Compilation Arguments") 'They are printed like this: A = 4 : B = 10 'That is how to test it: Sub TestMe() #If A = 1 Then Debug.Print "a is 1" #Else Debug.Print "a is not 1" #End If End Sub ================================================ FILE: Formatting/ConditionalFormat.vb ================================================ Sub ListAllConditionalFormat() Dim cf As FormatCondition Dim ws As Worksheet Dim l As Long Dim rngCell As Range On Error Resume Next Application.EnableEvents = False Application.ScreenUpdating = False tblReport.Cells.Clear For Each ws In ThisWorkbook.Worksheets Debug.Print ws.Name For Each cf In ws.Cells.FormatConditions l = 1 + l With tblReport Set rngCell = .Cells(l, 1) rngCell = cf.AppliesTo.Address rngCell.Offset(0, 1) = cf.Type rngCell.Offset(0, 2) = "'" & cf.Formula1 rngCell.Offset(0, 3) = cf.Interior.Color rngCell.Offset(0, 4) = cf.Font.Name rngCell.Offset(0, 5) = ws.Name rngCell.Offset(0, 6) = "'" & cf.AppliesTo.AddressLocal rngCell.Offset(0, 7) = "'" & cf.Formula2 End With Next cf Next ws Debug.Print "END!" End Sub ================================================ FILE: Formatting/CreateSheetRemoveSheet.vb ================================================ 'Create Make Sheet Worksheet 'Remove Sheet Worksheet 'Delete Sheet Worksheet Sub CreateWorksheet(sheetName As String) ThisWorkbook.Worksheets.Add.Name = sheetName End Sub Sub DeleteWorksheet(sheetName As String) Dim displayAlert As Boolean Dim mySheet As Worksheet displayAlert = Application.DisplayAlerts For Each mySheet In ThisWorkbook.Worksheets If mySheet.Name = sheetName Then Application.DisplayAlerts = False ThisWorkbook.Worksheets(sheetName).Delete Application.DisplayAlerts = displayAlert End If Next End Sub Sub DeleteAllButLast() Dim wksToStay As Worksheet Dim wksToDelete As Worksheet Dim i As Long Set wksToStay = ThisWorkbook.Worksheets(Worksheets.Count) For i = Worksheets.Count To 1 Step -1 Set wksToDelete = ThisWorkbook.Worksheets(i) If wksToDelete.Name <> wksToStay.Name Then Application.DisplayAlerts = False wksToDelete.Delete Application.DisplayAlerts = True End If Next End Sub ================================================ FILE: Formatting/DataCleaning.vb ================================================ Sub AddEmptyValueIfMissingInColumn() Dim myCell As Range Dim str As String For Each myCell In Selection If Len(Trim(myCell)) = 0 Then myCell = str Else str = myCell End If Next myCell End Sub Sub UnMergeSelection() Dim myCell As Range For Each myCell In Selection If myCell.MergeCells Then myCell.UnMerge End If Next End Sub ================================================ FILE: Formatting/FileNameWithDialogBox.vb ================================================ Option Explicit Public Sub MainBrowse(my_obj As Object) Dim str_file As String str_file = Application.GetOpenFilename(Title:="Please choose a file to open", FileFilter:="Excel Files *.xls* (*.xls*),") my_obj = str_file End Sub Private Sub btnBrowse_Click() Dim strInitial As String Dim objLabel As Object Set objLabel = ThisWorkbook.Worksheets(tbl_input.Name).lblDisplay strInitial = objLabel Call MainBrowse(objLabel) If Len(objLabel) >= 6 Then 'Falsch, False objLabel = strInitial End If End Sub ================================================ FILE: Formatting/FixRangeError.vb ================================================ Sub ErrorInFormulas() 'Formatting condition, conditional formatting, external Dim ws As Worksheet, r As Range Dim cf As FormatCondition For Each ws In Worksheets For Each r In ws.UsedRange If IsError(r) Then Debug.Print r.Parent.Name, r.Address, r.Formula End If Next For Each cf In ws.Cells.FormatConditions Debug.Print cf.AppliesTo.Address, cf.Type, cf.Formula1, cf.Interior.COLOR, cf.Font.Name, ws.Name Next Next End Sub Sub ListAllConditionalFormatting() Dim cf As FormatCondition Dim ws As Worksheet Set ws = ActiveSheet For Each cf In ws.Cells.FormatConditions Debug.Print cf.AppliesTo.Address, cf.Type, cf.Formula1, cf.Interior.COLOR, cf.Font.Name Next cf End Sub Sub ErrorList() Dim ws As Worksheet Dim rng1 As Range Dim strOut As String For Each ws In ThisWorkbook.Worksheets Set rng1 = Nothing On Error Resume Next Set rng1 = ws.Cells.SpecialCells(xlFormulas, xlErrors) On Error GoTo 0 If Not rng1 Is Nothing Then strOut = strOut & (ws.Name & " has " & rng1.Cells.count & " errors" & vbNewLine) Next ws If Len(strOut) > 0 Then Debug.Print "Error List:" & vbNewLine & strOut Else Debug.Print "No Errors" End If End Sub Sub FixRangeError() On Error GoTo FixRangeError_Error Dim r_range As Range Dim str_text As String Dim l_counter As Long Dim str_result As String Dim arr_result As Variant Dim arr_range As Variant For Each r_range In ActiveSheet.UsedRange str_text = "" If r_range.HasFormula Then ReDim arr_result(0) str_text = Replace(r_range.Formula, "=", "") arr_range = Split(str_text, "+") For l_counter = LBound(arr_range) To UBound(arr_range) If Not InStr(arr_range(l_counter), "#") > 0 Then ReDim Preserve arr_result(UBound(arr_result) + 1) arr_result(UBound(arr_result)) = arr_range(l_counter) End If Next l_counter For l_counter = LBound(arr_result) + 1 To UBound(arr_result) str_result = str_result & "+" & arr_result(l_counter) Next l_counter str_result = "=" & Right(str_result, Len(str_result) - 1) r_range.Formula = str_result End If Next r_range On Error GoTo 0 Exit Sub FixRangeError_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FixRangeError of Sub Modul1" End Sub '--------------------------------------------------------------------------------------- ' Method : FindMeTheCellWithError ' Author : v.doynov ' Date : 01.09.2017 ' Purpose: Show the errors. Print the errors in a worksheet. Look for errors. Search errors. '--------------------------------------------------------------------------------------- Public Sub FindMeTheCellWithError() Dim rngCell As Range Dim wks As Worksheet For Each wks In ThisWorkbook.Worksheets For Each rngCell In wks.UsedRange If IsError(rngCell) Then Debug.Print rngCell.Address Debug.Print rngCell.Parent.name End If Next rngCell Next wks End Sub ================================================ FILE: Formatting/GetWorkbook.vb ================================================ Public Function GetWorkbook(ByVal sFullName As String) As Workbook Dim sFile As String Dim wbReturn As Workbook sFile = Dir(sFullName) On Error Resume Next Workbooks(sFile).Close Set wbReturn = Workbooks(sFile) If wbReturn Is Nothing Then Set wbReturn = Workbooks.Open(sFullName) End If On Error GoTo 0 Set GetWorkbook = wbReturn End Function Public Function calculate_range(from_row As Long, to_row As Long, l_column As Long, _ Optional s_sheet_name As String = "calendar") As Double Dim ws As Worksheet Dim l_counter As Long Dim d_result As Double Set ws = ThisWorkbook.Worksheets(s_sheet_name) For l_counter = from_row To to_row Call Increment(d_result, ws.Cells(l_counter, l_column)) Next l_counter Set ws = Nothing calculate_range = Round(d_result, 2) End Function Function IsWorkbookOpen(wbk As Workbook) As Boolean 'Opened Workbook, open workbook Dim checkWbk As Workbook On Error Resume Next Set checkWbk = Workbooks(wbk.Name) On Error GoTo 0 If checkWbk Is Nothing Then IsWorkbookOpen = False Else IsWorkbookOpen = True End If End Function ================================================ FILE: Formatting/IgnoreCellErrors.vb ================================================ Public Sub IgnoreCellErrors() Dim rngCell As Range Dim cnt As Long For Each rngCell In ActiveSheet.UsedRange For cnt = 1 To 8 rngCell.Errors(cnt).Ignore = True Next cnt Next rngCell End Sub ================================================ FILE: Formatting/InsertIntoString.vb ================================================ Function InsertIntoString(originalString As String, addedString As String, positionToAdd As Long) As String If positionToAdd < 1 Then positionToAdd = 1 If Len(originalString) < positionToAdd Then positionToAdd = Len(originalString) + 1 InsertIntoString = Mid(originalString, 1, positionToAdd - 1) _ & addedString _ & Mid(originalString, positionToAdd, Len(originalString) - positionToAdd + 1) End Function Public Sub TestInsertIntoString() Debug.Print InsertIntoString("vitosh", "academy", 1000) = "vitoshacademy" Debug.Print InsertIntoString("academy", "vit", -6) = "vitacademy" Debug.Print InsertIntoString("vitacademy", "osh", 4) = "vitoshacademy" Debug.Print InsertIntoString("abcd", "ff", 3) = "abffcd" Debug.Print InsertIntoString("abcd", "ff", 4) = "abcffd" Debug.Print InsertIntoString("abcd", "ff", 100) = "abcdff" End Sub ================================================ FILE: Formatting/OpenAndClose.vb ================================================ Private Sub Workbook_BeforeClose(Cancel As Boolean) Cancel = False ThisWorkbook.Save Application.DisplayAlerts = False Call HideNeeded Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" Application.DisplayAlerts = True ActiveWindow.DisplayHeadings = True Application.DisplayFormulaBar = True ActiveSheet.PageSetup.BlackAndWhite = False End Sub Private Sub Workbook_NewSheet(ByVal Sh As Object) paku_message_title = tbl_settings.Range("AJ8") If Not tbl_settings.Visible Then With Application Application.ScreenUpdating = False Application.DisplayAlerts = False Sh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End With MsgBox (Environ("UserName") & ", Sie können Blätter nicht hinzufügen."), vbInformation, paku_message_title End If End Sub Private Sub Workbook_Open() Call HideNeeded Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", false)" Application.DisplayFormulaBar = False [set_root_user] = False Application.Caption = "" End Sub Public Sub HideNeeded() Dim var_Sheet As Variant Dim arr_visible_sheets As Variant Dim arr_hidden_sheets As Variant Call OnStart arr_visible_sheets = Array(tbl_Input) arr_hidden_sheets = Array(tbl_1, tbl_2, tbl_3) For Each var_Sheet In arr_visible_sheets var_Sheet.Visible = xlSheetVisible Next var_Sheet For Each var_Sheet In arr_hidden_sheets var_Sheet.Visible = xlSheetVeryHidden Next var_Sheet Call OnEnd End Sub Public Sub UnhideAll() Dim Sheet As Worksheet For Each Sheet In ThisWorkbook.Worksheets ' If Sheet.Visible = Not xlSheetVisible Then Sheet.Visible = xlSheetVisible Sheet.Visible = xlSheetVisible Next Sheet Call UnprotectAll End Sub ================================================ FILE: Formatting/RangeConnector.vb ================================================ Sub FormatHalfOfTheSelectedCell() Dim myRange As Range Dim color As Long: color = RGB(0, 0, 0) Dim myShape As Shape With Worksheets("Sheet1") 'With ActiveSheet Set myRange = .Range("E10") 'Selection Dim left As Long: left = myRange.left Dim top As Long: top = myRange.top Dim width As Long: width = myRange.width Dim heigth As Long: heigth = myRange.Height 'Top line: Set myShape = .Shapes.AddConnector(msoConnectorStraight, left, top, left + width / 2, top) myShape.Line.ForeColor.RGB = color 'Left line: Set myShape = .Shapes.AddConnector(msoConnectorStraight, left, top, left, top + myRange.Height) myShape.Line.ForeColor.RGB = color 'Right line: Set myShape = .Shapes.AddConnector(msoConnectorStraight, left + width / 2, top, left + width / 2, top + myRange.Height) myShape.Line.ForeColor.RGB = color Set myRange = myRange.Offset(1) left = myRange.left top = myRange.top width = myRange.width heigth = myRange.Height 'Bottom line: Set myShape = .Shapes.AddConnector(msoConnectorStraight, left, top, left + width / 2, top) myShape.Line.ForeColor.RGB = RGB(200, 0, 0) End With End Sub Sub FormatRightPartOfSelectedCell() Dim myRange As Range Dim color As Long: color = RGB(0, 0, 0) Dim myShape As Shape With Worksheets("Sheet1") 'With ActiveSheet Set myRange = .Range("E10") 'Selection Dim left As Long: left = myRange.left Dim top As Long: top = myRange.top Dim width As Long: width = myRange.width Dim heigth As Long: heigth = myRange.Height 'Top line: Set myShape = .Shapes.AddConnector(msoConnectorStraight, left + (width) / 2, top, left + width, top) myShape.Line.ForeColor.RGB = color 'Right line Set myShape = .Shapes.AddConnector(msoConnectorStraight, left + width, top, left + width, top + myRange.Height) myShape.Line.ForeColor.RGB = color Set myRange = myRange.Offset(1) left = myRange.left top = myRange.top width = myRange.width heigth = myRange.Height 'Bottom Line: Set myShape = .Shapes.AddConnector(msoConnectorStraight, left + (width) / 2, top, left + width, top) myShape.Line.ForeColor.RGB = RGB(200, 0, 0) End With End Sub ================================================ FILE: Formatting/RemoveWorksheet.vb ================================================ Option Explicit Public Sub Main() Dim objFso As Object Dim objFol As Object Dim objFil As Object Dim objWb As Workbook Dim objWs As Worksheet Dim lngCounter As Long Dim strNameToDelete As String: strNameToDelete = UCase(tblMAin.Cells(1, 1)) Dim strNameDeleted As String Call OnStart Set objFso = CreateObject("Scripting.FileSystemObject") Set objFol = objFso.getfolder(ThisWorkbook.Path) strTextSummary = Now & vbCrLf Application.StatusBar = "Running ..." For Each objFil In objFol.Files If ((Not InStr(1, objFil.Name, "$") > 1) And _ (Not InStr(1, objFil.Name, "~") > 1) And _ (objFil.Name <> ThisWorkbook.Name) And _ InStr(1, objFil.Name, "xls") > 1) Then Set objWb = Workbooks.Open(objFil.Path) Application.StatusBar = objFil.Name For lngCounter = objWb.Worksheets.Count To 1 Step -1 If UCase(Left(objWb.Worksheets(lngCounter).Name, Len(strNameToDelete))) = strNameToDelete Then strNameDeleted = objWb.Worksheets(lngCounter).Name objWb.Worksheets(lngCounter).Delete strTextSummary = strTextSummary & objWb.Name & vbCrLf & vbTab & strNameDeleted & vbCrLf End If Next lngCounter objWb.Close True End If Next objFil CreateLogFile Call OnEnd End Sub Function WorksheetExists(sheetName As String) As Boolean WorksheetExists = Not WorksheetFunction.IsErr(Evaluate("'" & sheetName & "'!A1")) End Function ================================================ FILE: Formatting/Rgb2HtmlColor.vb ================================================ Option Explicit 'RGB2HTMLColor html htmlcolor 'INPUT: Numeric (Base 10) Values for R, G, and B) 'OUTPUT: 'String to be used for color of element in VBA. 'E.G -> if the color is like this:-> &H80000005& 'we should change just the last 6 positions to get our color! H80 must stay. Public Function RGB2HTMLColor(B As Byte, G As Byte, R As Byte) As String Dim HexR As Variant, HexB As Variant, HexG As Variant Dim sTemp As String On Error GoTo ErrorHandler 'R HexR = Hex(R) If Len(HexR) < 2 Then HexR = "0" & HexR 'Get Green Hex HexG = Hex(G) If Len(HexG) < 2 Then HexG = "0" & HexG HexB = Hex(B) If Len(HexB) < 2 Then HexB = "0" & HexB RGB2HTMLColor = HexR & HexG & HexB Debug.Print "Enter RGB, without caring for the real colors, the function knows what it is doing." Debug.Print "IF 50D092 then &H0050D092&" Exit Function ErrorHandler: Debug.Print "RGB2HTMLColor was not successful" End Function Sub GetHexFromInteriorCell() Worksheets(1).Cells(1, "A").Interior.Color = vbYellow Debug.Print Hex(Worksheets(1).Cells(1, "A").Interior.Color) 'FFFF Debug.Print Worksheets(1).Cells(1, "A").Interior.Color '65535 Dim hexColor As String hexColor = Right("000000" & Hex(Worksheets(1).Cells(1, "A").Interior.Color), 6) Debug.Print HexToRgb(hexColor) 'FFFF00 End Sub Public Function HexToRgb(hexColor As String) As String Dim red As String Dim green As String Dim blue As String red = Left(hexColor, 2) green = Mid(hexColor, 3, 2) blue = Right(hexColor, 2) HexToRgb = blue & green & red End Function ================================================ FILE: Formatting/SetPrintArea.vb ================================================ Public Sub SetPrintArea() Dim r_print_range As Range Set r_print_range = tbl_plan.Range(Cells(1, 1), Cells(obj_plan.LastLine, obj_cal.RightColPosition)) With tbl_plan.PageSetup .LeftHeader = "" .CenterHeader = "&""Calibri,bold""&25" & "Ankaufsunterlagen" .PrintArea = r_print_range.Address .FitToPagesWide = 1 .FitToPagesTall = 1 .Orientation = xlLandscape End With End Sub ================================================ FILE: Formatting/Shapes.vb ================================================ Option Explicit Sub ShapeNames() Dim sh_shape As shape For Each sh_shape In ActiveSheet.Shapes Debug.Print sh_shape.Name Next sh_shape End Sub Public Sub GetSomething(str_something As String) ActiveSheet.Shapes(str_something).Select End Sub 'Makes shape visible and invisble. Sub translatorField_Klicken() Dim blnEnglish As Boolean Dim rngRange As Range Dim myShape As shape Set myShape = tblInput.Shapes("translatorField") Set rngRange = tblSettings.Cells(2, 2) blnEnglish = Not CBool(rngRange) tblSettings.Cells(2, 2) = blnEnglish If blnEnglish Then tblInput.[h1].value = tblSettings.[i1].value With myShape.Fill .ForeColor.RGB = RGB(0, 0, 0) .Transparency = 1 End With With myShape.TextFrame2.TextRange.Characters(1, 66).Font.Fill .ForeColor.RGB = RGB(255, 255, 255) .Transparency = 1 End With Else tblInput.[h1].value = tblSettings.[c1].value With myShape.Fill .ForeColor.RGB = RGB(255, 255, 255) .Transparency = 0 End With With myShape.TextFrame2.TextRange.Characters(1, 66).Font.Fill .ForeColor.RGB = RGB(0, 0, 0) .Transparency = 0 End With End If End Sub '--------------------------------------------------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------------------------------------------------- Option Explicit Sub TestMe() Dim shp As Shape Dim arrOfShapes() As Variant With ActiveSheet For Each shp In .Shapes If InStrB(shp.Name, "Rec") > 0 Then arrOfShapes = incrementArray(arrOfShapes, shp.Name) End If Next If IsArrayAllocated(arrOfShapes) Then Debug.Print .Shapes.Range(arrOfShapes(0)).Name .Shapes.Range(arrOfShapes).Delete End If End With End Sub Public Function incrementArray(arrOfShapes As Variant, nameOfShape As String) As Variant Dim cnt As Long Dim arrNew As Variant If IsArrayAllocated(arrOfShapes) Then ReDim arrNew(UBound(arrOfShapes) + 1) For cnt = LBound(arrOfShapes) To UBound(arrOfShapes) arrNew(cnt) = CStr(arrOfShapes(cnt)) Next cnt arrNew(UBound(arrOfShapes) + 1) = CStr(nameOfShape) Else arrNew = Array(nameOfShape) End If incrementArray = arrNew End Function Function IsArrayAllocated(Arr As Variant) As Boolean On Error Resume Next IsArrayAllocated = IsArray(Arr) And _ Not IsError(LBound(Arr, 1)) And _ LBound(Arr, 1) <= UBound(Arr, 1) End Function Credits to this guy for the finding that the arrOfShapes should be declared with parenthesis (I have spent about 30 minutes researching why I could not pass it correctly) and to CPearson for the IsArrayAllocated(). ================================================ FILE: Formatting/Shortcuts/README.md ================================================ # VBA Shortcusts Here are the shortcuts, that I use mainly in VBA. I have used the structure of [CPearson](http://www.cpearson.com/excel/vbashortcutkeys.htm) and I have added some more, that I consider valuable. | Key | Alone | Shift | Ctrl | Alt | Shift Ctrl | |----------------------|-----------------------|-------------------------|---------------------------|-------------------------------|-------------------------| | F1 | Help | | | | | | F2 | Object Browser | Procedure Definition | Focus To Object Box | | Previous Position | | F3 | Copy | Find Prev | | | | | F4 | Properies Window | Find Next | Close Window | Close VBE | | | F5 | Run | | | Run Error Handler | | | F6 | Switch Split Windows | | | Switch Between Last 2 Windows | | | F7 | Goto Window Of Object | With UF | | Step Error Handler | | | F8 | Step | Procedure Step | Run To Cursor | | Go Upstairs | | F9 | Breakpoint | Quick Watch | Drag to cursor | | Clear All Breakpoints | | F10 | Activate Menu Bar | Show Right Click Menu | Activate Menu Bar | | | | F11 | | | | Return To Application | | | A | Normal Characters | | | Add-Ins Menu | | | B | | | Select All Text | | | | C | | | Copy | | | | D | | | | Debug Menu | | | E | | | Export Module | Edit Menu | | | F | | | Find | File Menu | | | G | | | Immediate Window | | | | H | | | Replace | Help Menu | | | I | | | Turn On Quick Info | | Turn On Param Info | | J | | | List Members | Insert Menu | Turn On List Properties | | L | | | Show Call Stack | | | | M | | | Import File | | | | N | | | New Line | | | | O | | | | Format Menu | | | P | | | Print | | | | Q | | | | Close & Return | | | R | | | Project Window | Run Menu | | | S | | | Save | | | | T | | | Show Available Components | Tools Menu | | | V | | | Paste | View Menu | | | W | | | | Window Menu | | | Y | | | Cut Entire Line | | | | Insert | Toggle Insert Mode | Paste | Copy | | | | Delete | Delete | | Delete To End Of Word | | | | Home | Beginning Of Line | Select To Start Of Line | Top Of Module | | | | End | End Of Line | Select To End Of Line | End Of Module | | | | Page Up | Page Up | Select To Top Of Module | Top Of Current Procedure | | | | Page Down | Page Down | Select To End Of Module | End Of Current Procedure | | | | ↑ | Up | Extend Selection Up | Previous Procedure | | | | ↓ | Down | Extend Selection Down | Next Procedure | | | | Space Bar | | | Turn On Complete Word | System Menu | | | Tab | Indent | Un-indent | Cycle Windows | Cycle Applications | | | Enter | New Line | | | | | | BackSpace | Delete Prev Char | | Delete To Start Of Word | Undo | | | Application.SendKeys | | + | ^ | % | %^ | | Specials in Excel | | | | | | | | Alt | vitoshacademy.com | | | | | 0178 | m² | | | | | | 0128 | € | | | | | | 0216 | Ø | | | | | | 24-28 | ↑ ↓ → ← | | | | | | Excel | | | | | | | F2 | | | Print properties | | | | F3 | | | Names | | | | F9 | | | Maximize Window | | | | F10 | | | Minimize Window | | | | F11 | | | Add Tab | | | | F12 | | | Open File | | | | Visual Studio | | | | | | | Ctrl + K + C | Comment | | | | | | Ctrl + K + U | Uncomment | | | | | | Ctrl + K + F | Indent | | | | | | F10 | Next step | | | | | | Ctrl + F11 | Run to line | | | | | Good luck, have fun from [VitoshAcademy](http://www.vitoshacademy.com) :cactus::beer: ================================================ FILE: Formatting/SplitValuesSingleColumnToCells.vb ================================================ Option Explicit Public Sub SplitSingleColumnToCells() Dim rngInput As Range Dim rngOutput As Range Dim myCell As Range 'Set manually, it is faster :) Set rngInput = Range("A1:A22") For Each myCell In rngInput 'replace multiple space with single space: myCell = Replace(myCell, Chr(32), Chr(32)) Dim inputArray As Variant inputArray = Split(myCell) Dim col As Long Dim i As Long col = 0 For i = LBound(inputArray) To UBound(inputArray) If Len(inputArray(i)) > 0 Then col = col + 1 myCell.Offset(0, col) = inputArray(i) End If Next i 'Probably not needed: 'myCell.Clear Next myCell End Sub ================================================ FILE: Formatting/StyleKiller.vb ================================================ Option Explicit Sub StyleKiller() Dim myStyle As Style Dim lngCounter As Long For Each myStyle In ThisWorkbook.Styles If Not myStyle.BuiltIn Then Debug.Print myStyle.name myStyle.Delete lngCounter = lngCounter + 1 End If Next myStyle Debug.Print "Ende" Debug.Print "Deleted " & lngCounter End Sub 'FANCY ONE: '************************************************************************************** Sub RemoveTheStyles() Dim style As style Dim l_counter As Long Dim l_total_number As Long On Error Resume Next l_total_number = ActiveWorkbook.Styles.Count Application.ScreenUpdating = False For l_counter = l_total_number To 1 Step -1 Set style = ActiveWorkbook.Styles(l_counter) If (l_counter Mod 500 = 0) Then DoEvents Application.StatusBar = "Deleting " & l_total_number - l_counter + 1 & " of " & l_total_number & " " & style.Name End If If Not style.BuiltIn Then style.Delete Next l_counter Application.ScreenUpdating = True Application.StatusBar = False Debug.Print "READY!" On Error GoTo 0 End Sub 'https://support.microsoft.com/en-us/help/291321/how-to-programmatically-reset-a-workbook-to-default-styles Sub RebuildDefaultStyles() 'The purpose of this macro is to remove all styles in the active 'workbook and rebuild the default styles. 'It rebuilds the default styles by merging them from a new workbook. 'Dimension variables. Dim MyBook As Workbook Dim tempBook As Workbook Dim CurStyle As Style 'Set MyBook to the active workbook. Set MyBook = ActiveWorkbook On Error Resume Next 'Delete all the styles in the workbook. For Each CurStyle In MyBook.Styles 'If CurStyle.Name <> "Normal" Then CurStyle.Delete Select Case CurStyle.Name Case "20% - Accent1", "20% - Accent2", _ "20% - Accent3", "20% - Accent4", "20% - Accent5", "20% - Accent6", _ "40% - Accent1", "40% - Accent2", "40% - Accent3", "40% - Accent4", _ "40% - Accent5", "40% - Accent6", "60% - Accent1", "60% - Accent2", _ "60% - Accent3", "60% - Accent4", "60% - Accent5", "60% - Accent6", _ "Accent1", "Accent2", "Accent3", "Accent4", "Accent5", "Accent6", _ "Bad", "Calculation", "Check Cell", "Comma", "Comma [0]", "Currency", _ "Currency [0]", "Explanatory Text", "Good", "Heading 1", "Heading 2", _ "Heading 3", "Heading 4", "Input", "Linked Cell", "Neutral", "Normal", _ "Note", "Output", "Percent", "Title", "Total", "Warning Text" 'Do nothing, these are the default styles Case Else CurStyle.Delete End Select Next CurStyle 'Open a new workbook. Set tempBook = Workbooks.Add 'Disable alerts so you may merge changes to the Normal style 'from the new workbook. Application.DisplayAlerts = False 'Merge styles from the new workbook into the existing workbook. MyBook.Styles.Merge Workbook:=tempBook 'Enable alerts. Application.DisplayAlerts = True 'Close the new workbook. tempBook.Close End Sub ================================================ FILE: Internet/AmazonInternet.bas ================================================ Attribute VB_Name = "AmazonInternet" Option Explicit Public Function PageWithResultsExists(appIE As Object, keyword As String) As Boolean On Error GoTo PageWithResultsExists_Error Dim allData As Object Set allData = appIE.document.getElementById("s-results-list-atf") PageWithResultsExists = True IeErrors = 0 On Error GoTo 0 Exit Function PageWithResultsExists_Error: WaitSomeMilliseconds IeErrors = IeErrors + 1 Select Case Err.Number Case 424 If IeErrors > MAX_IE_ERRORS Then PageWithResultsExists = False IeErrors = 0 Else LogMe "PageWithResultsExists", IeErrors, keyword, IeErrors PageWithResultsExists appIE, keyword End If Case Else Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext End Select End Function Public Function MakeUrl(i As Long, keyword As String) As String MakeUrl = "https://www.amazon.com/s/ref=sr_pg_" & i & "?rh=i%3Aaps%2Ck%3A" & keyword & "&page=" & i & "&keywords=" & keyword End Function Public Sub Navigate(i As Long, appIE As Object, keyword As String) Do While appIE.Busy DoEvents Loop With appIE .Navigate MakeUrl(i, keyword) .Visible = False End With Do While appIE.Busy DoEvents Loop End Sub ================================================ FILE: Internet/ConstValues.bas ================================================ Attribute VB_Name = "ConstValues" Option Explicit Public IeErrors As Long Public Const MAX_IE_ERRORS = 10 Public Const IN_PRODUCTION = False ================================================ FILE: Internet/ExcelRelated.bas ================================================ Attribute VB_Name = "ExcelRelated" Option Explicit Public Function GetNextKeyWord() As String With tblInput Dim lastRowB As Long lastRowB = lastRow(.Name, 2) + 1 GetNextKeyWord = Trim(.Cells(lastRowB, 1)) If Len(GetNextKeyWord) <> 0 Then .Cells(lastRowB, 2) = Now End With End Function Public Sub WriteFormulas() Dim i As Long With tblInput For i = lastRow(.Name) To 2 Step -1 .Cells(i, 3).FormulaR1C1 = "=COUNTIF(Summary!C[1],Input!RC[-2])" .Cells(i, 4).FormulaArray = "=MAX(IF(Summary!C=RC[-3],Summary!C[-1]))" FormatUSD .Cells(i, 4) .Cells(i, 5).FormulaArray = "=AVERAGE(IF(Summary!C[-1]=Input!RC[-4],Summary!C[-2]))" FormatUSD .Cells(i, 5) Next i End With End Sub Public Sub FixWorksheets() OnStart With tblInput .Range("B1") = "Start Time" .Range("C1") = "Count" .Range("D1") = "Max" .Range("E1") = "Average" End With With tblSummary .Range("A1") = "Title" .Range("B1") = "Author" .Range("C1") = "Price" .Range("D1") = "Keyword" End With Dim ws As Worksheet For Each ws In Worksheets ws.Columns.AutoFit Next ws OnEnd End Sub Public Sub FormatUSD(myRange As Range) myRange.NumberFormat = "_-[$$-409]* #,##0.00_ ;_-[$$-409]* -#,##0.00 ;_-[$$-409]* ""-""??_ ;_-@_ " End Sub Public Sub CleanWorksheets() tblRawData.Cells.Delete tblSummary.Cells.Delete tblInput.Columns("B:F").Delete End Sub Public Function GetNthString(n As Long, myRange As Range) As String Dim i As Long Dim myVar As Variant myVar = Split(myRange, vbCrLf) For i = LBound(myVar) To UBound(myVar) If Len(myVar(i)) > 0 And n = 0 Then GetNthString = myVar(i) Exit Function ElseIf Len(myVar(i)) > 0 Then n = n - 1 End If Next i End Function Public Function GetPrice(myRange As Range) As String Dim i As Long Dim myVar As Variant myVar = Split(myRange, "$") If UBound(myVar) > 0 Then GetPrice = Mid(myVar(1), 1, InStr(1, myVar(1), " ")) Else GetPrice = "" End If End Function Public Sub WriteToExcel(appIE As Object, keyword As String) If IN_PRODUCTION Then On Error GoTo WriteToExcel_Error Dim allData As Object Set allData = appIE.document.getElementById("s-results-list-atf") Dim book As Object Dim myRow As Long For Each book In allData.getElementsByClassName("a-fixed-left-grid-inner") With tblRawData myRow = lastRow(.Name) + 1 On Error Resume Next .Cells(myRow, 1) = book.innertext .Cells(myRow, 2) = keyword On Error GoTo 0 End With Next IeErrors = 0 On Error GoTo 0 Exit Sub WriteToExcel_Error: IeErrors = IeErrors + 1 If IeErrors > MAX_IE_ERRORS Then Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure WriteToExcel, line " & Erl & "." Else LogMe "WriteToExcel", IeErrors, keyword, IeErrors WriteToExcel appIE, keyword End If End Sub Public Sub RawDataToStructured(keyword As String, firstRow As Long) Dim i As Long For i = firstRow To lastRow(tblRawData.Name) With tblRawData If InStr(1, .Cells(i, 1), "Sponsored ") < 1 Then Dim title As String title = GetNthString(0, .Cells(i, 1)) Dim author As String author = GetNthString(1, .Cells(i, 1)) Dim price As String price = GetPrice(.Cells(i, 1)) If Not IsNumeric(price) Or price = "0" Then price = "" Dim currentRow As String: currentRow = lastRow(tblSummary.Name) + 1 With tblSummary .Cells(currentRow, 1) = title .Cells(currentRow, 2) = author .Cells(currentRow, 3) = price .Cells(currentRow, 4) = keyword End With End If End With Next i End Sub Public Function lastRow(wsName As String, Optional columnToCheck As Long = 1) As Long Dim ws As Worksheet Set ws = Worksheets(wsName) lastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row End Function ================================================ FILE: Internet/General.bas ================================================ Attribute VB_Name = "General" Option Explicit Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.AskToUpdateLinks = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False Application.StatusBar = False End Sub Public Sub OnStart() Application.ScreenUpdating = False Application.EnableEvents = False Application.AskToUpdateLinks = False Application.DisplayAlerts = False Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False ActiveWindow.View = xlNormalView End Sub Public Sub LogMe(ParamArray arg() As Variant) Debug.Print Join(arg, "--") End Sub Public Sub PrintMeUsefulFormula() Dim strFormula As String Dim strParenth As String strParenth = """" strFormula = Selection.FormulaR1C1 strFormula = Replace(strFormula, """", """""") strFormula = strParenth & strFormula & strParenth Debug.Print strFormula End Sub Public Sub WaitSomeMilliseconds(Optional Milliseconds As Long = 1000) Sleep Milliseconds End Sub ================================================ FILE: Internet/GotoInternet.vb ================================================ Public Sub Clicked(Optional b_logo As Boolean = False) Dim ie As Object Dim s_WebSites() As Variant On Error GoTo Clicked_Error If b_logo Then s_WebSites = Array("https://www.facebook.com", _ "https://plus.google.com", _ "http://www.youtube.com") Else s_WebSites = Array("http://www.hoai.de/online/hoai_rechner") End If ' s_WebSites = Array("https://goo.gl/c3Gzqi", _ ' "https://goo.gl/JKvYR6", _ ' "https://goo.gl/eLuMFN", _ ' "https://goo.gl/r2OMeQ") Set ie = CreateObject("Internetexplorer.Application") ie.Visible = True ie.Navigate s_WebSites(make_random(0, UBound(s_WebSites))) Exit Sub On Error GoTo 0 Exit Sub Clicked_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Clicked of Module mod_main" End Sub Public Function CheckUrlExists(url) As Boolean On Error GoTo CheckUrlExists_Error Dim xmlhttp As Object Set xmlhttp = CreateObject("MSXML2.XMLHTTP") xmlhttp.Open "HEAD", url, False xmlhttp.send If xmlhttp.Status = 200 Then CheckUrlExists = True Else CheckUrlExists = False End If Exit Function CheckUrlExists_Error: CheckUrlExists = False End Function ================================================ FILE: Internet/README.md ================================================ This is the code from the article here: http://www.vitoshacademy.com/vba-data-scraping-from-internet-with-excel-part-2/ Some time ago I wrote an article for Data scraping from Internet with Excel, which was scraping book information from amazon.com, based on a given word. The code was 25 lines, thus it had some points for improvement. Thus, I have decided to make something bigger out of it with some additional options: - writing it to Excel, instead of printing to the immediate window - getting the prices of the books - scraping multiple titles - creating some user interface and reporting - analyzing the data :cactus: ================================================ FILE: Internet/StartUp.bas ================================================ Attribute VB_Name = "StartUp" Option Explicit Public Sub Main() If IN_PRODUCTION Then On Error GoTo Main_Error CleanWorksheets Dim keyword As String: keyword = GetNextKeyWord While keyword <> "" Dim appIE As Object Set appIE = CreateObject("InternetExplorer.Application") LogMe keyword Dim nextPageExists As Boolean: nextPageExists = True Dim i As Long: i = 1 Dim firstRow As Long: firstRow = lastRow(tblRawData.Name) + 1 While nextPageExists WaitSomeMilliseconds Navigate i, appIE, keyword nextPageExists = PageWithResultsExists(appIE, keyword) If nextPageExists Then WriteToExcel appIE, keyword i = i + 1 Wend LogMe Time, keyword, "RawDataToStructured" RawDataToStructured keyword, firstRow keyword = GetNextKeyWord WaitSomeMilliseconds 4000 appIE.Quit Wend FixWorksheets WriteFormulas LogMe "Program has ended!" On Error GoTo 0 Exit Sub Main_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Main, line " & Erl & "." End Sub ================================================ FILE: OOP/AttributesInVBA/CarGlobal.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "CarGlobal" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private m_sModel As String Private m_Price As Currency Private Sub Class_Initialize() Model = "Global nice model" Price = 200 End Sub Public Property Get Model() As String Model = m_sModel End Property Public Property Let Model(ByVal sNewValue As String) m_sModel = sNewValue End Property Public Property Get Price() As Currency Price = m_Price End Property Public Property Let Price(ByVal NewValue As Currency) m_Price = NewValue End Property Public Function ChangePrice(newPrice As Currency) As Currency Price = Price + newPrice ChangePrice = Price End Function ================================================ FILE: OOP/AttributesInVBA/CarWithDefaultProperty.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "CarWithDefaultProperty" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private m_sModel As String Private m_Price As Currency Private Sub Class_Initialize() Model = "Car with default property model" Price = 2000 End Sub Public Property Get Model() As String Model = m_sModel End Property Public Property Let Model(ByVal sNewValue As String) m_sModel = sNewValue End Property Public Property Get Price() As Currency Attribute Price.VB_Description = "Some nice description should be here." Attribute Price.VB_UserMemId = 0 Price = m_Price End Property Public Property Let Price(ByVal NewValue As Currency) m_Price = NewValue End Property Public Function ChangePrice(newPrice As Currency) As Currency Price = Price + newPrice ChangePrice = Price End Function ================================================ FILE: OOP/AttributesInVBA/ExportModule.bas ================================================ Attribute VB_Name = "ExportModule" '--------------------------------------------------------------------------------------- ' File : ExportModule ' Author : v.doynov ' Date : 13.12.2017 ' Purpose: Run `ExportAll` to export all the VBE code w/o the worksheets. ' Add `Microsoft Visual Basic for Applications Extensibility 5.3 library` ' to run it. '--------------------------------------------------------------------------------------- Option Explicit Public Sub ExportAndDelete() Dim sourceFile As String sourceFile = "C:\Users\v.doynov\Desktop\NeuerOrdner\" If Right(sourceFile, 1) <> "\" Then MsgBox "Make sure that you have ""\""" Exit Sub End If Kill sourceFile & "*.*" ExportSourceFiles (sourceFile) End Sub Public Sub ExportSourceFiles(destPath As String) Dim component As VBComponent For Each component In Application.VBE.ActiveVBProject.VBComponents If component.Type = vbext_ct_ClassModule Or component.Type = vbext_ct_StdModule Then component.Export destPath & component.Name & ToFileExtension(component.Type) End If Next End Sub Private Function ToFileExtension(vbeComponentType As vbext_ComponentType) As String Select Case vbeComponentType Case vbext_ComponentType.vbext_ct_ClassModule ToFileExtension = ".cls" Case vbext_ComponentType.vbext_ct_StdModule ToFileExtension = ".bas" Case vbext_ComponentType.vbext_ct_MSForm ToFileExtension = ".frm" Case vbext_ComponentType.vbext_ct_ActiveXDesigner Case vbext_ComponentType.vbext_ct_Document Case Else ToFileExtension = vbNullString End Select End Function ================================================ FILE: OOP/AttributesInVBA/MainModule.bas ================================================ Attribute VB_Name = "MainModule" Option Explicit Public Sub Main() 'Because of ' Attribute VB_PredeclaredId = True 'we can refer to CarGlobal without initialization: Debug.Print CarGlobal.Price Debug.Print CarGlobal.Model Debug.Print CarGlobal.ChangePrice(100) Debug.Print CarGlobal.Price 'Because of ' Attribute Value.VB_Description = "" ' Attribute Value.VB_UserMemId = 0 'the car has a a default property Price and it has description in the VBEditor Dim car As New CarWithDefaultProperty Debug.Print car 'Because of ' Attribute Value.VB_UserMemId = 0 ' Attribute Value.VB_Description = "Increases the price with 10. It is the default." Dim truck As New TruckWithDefaultProcedure Debug.Print truck.Price truck truck Debug.Print truck.Price End Sub ================================================ FILE: OOP/AttributesInVBA/ReadMe.md ================================================ ## VBTricks
3 classes are in the sample: - with a default property (CarWithDefaultPropery.cls) - with a default procedure (TruckWithDefaultProcedure.cls) - with a non required initialization (CarGlobal.cls) - automatic export of everything but the worksheets to a set up file With courtesy to: - http://www.stackoverflow.com - https://christopherjmcclellan.wordpress.com/2015/04/21/vb-attributes-what-are-they-and-why-should-we-use-them - http://www.cpearson.com/excel/vbe.aspx ================================================ FILE: OOP/AttributesInVBA/TruckWithDefaultProcedure.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "TruckWithDefaultProcedure" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private m_sModel As String Private m_Price As Currency Private Sub Class_Initialize() Model = "Some truck model" Price = 250 End Sub Public Property Get Model() As String Model = m_sModel End Property Public Property Let Model(ByVal sNewValue As String) m_sModel = sNewValue End Property Public Property Get Price() As Currency Price = m_Price End Property Public Property Let Price(ByVal NewValue As Currency) m_Price = NewValue End Property Public Function IncreasePriceWith10() Attribute IncreasePriceWith10.VB_Description = "Increases the price with 10. It is the default." Attribute IncreasePriceWith10.VB_UserMemId = 0 Price = Price + 10 Debug.Print "The price is now " & Price End Function ================================================ FILE: OOP/CopyObjectInVBA/Employee.cls.txt ================================================ Option Explicit Private Memento As MyMemento Friend Sub SetMemento(NewMemento As MyMemento) Memento = NewMemento End Sub Public Function Copy() As Employee Dim Result As Employee Set Result = New Employee Result.SetMemento Memento Set Copy = Result End Function Public Property Get Salary() As Double Salary = Memento.Salary End Property Public Property Let Salary(value As Double) Memento.Salary = value End Property Public Property Get Age() As Long Age = Memento.Age End Property Public Property Let Age(value As Long) Memento.Age = value End Property Public Property Get RelevantExperience() As Long RelevantExperience = Memento.RelevantExperience End Property Public Property Let RelevantExperience(value As Long) Memento.RelevantExperience = value End Property ================================================ FILE: OOP/CopyObjectInVBA/MainModule.vb.txt ================================================ Option Explicit Type MyMemento Salary As Double Age As Long RelevantExperience As Long End Type Sub Main() Dim newEmp As Employee Dim oldEmp As Employee Set newEmp = New Employee With newEmp .Salary = 100 .Age = 22 .RelevantExperience = 1 End With Set oldEmp = newEmp.Copy With oldEmp 'Salary is inherited, thus the same .Age = 99 .RelevantExperience = 10 End With Debug.Print "Salary"; vbCrLf; newEmp.Salary, oldEmp.Salary Debug.Print "Experience"; vbCrLf; newEmp.RelevantExperience, oldEmp.RelevantExperience Debug.Print "Age"; vbTab; vbCrLf; newEmp.Age, oldEmp.Age End Sub ================================================ FILE: OOP/CopyObjectInVBA/ReadMe.md ================================================ Files for article in [VitoshAcademy](https://www.vitoshacademy.com): VBA – How to copy a new object in VBA, without copying its reference https://www.vitoshacademy.com/vba-how-to-copy-a-new-object-in-vba-without-copying-its-reference/ :cactus::kiss: ================================================ FILE: OOP/DictionaryAndArray/CollectionToArray.vb ================================================ Public Function CollectionToArray(myCol As Collection) As Variant Dim result As Variant Dim cnt As Long If myCol.Count = 0 Then CollectionToArray = Array() Exit Function End If ReDim result(myCol.Count - 1) For cnt = 0 To myCol.Count - 1 result(cnt) = myCol(cnt + 1) Next cnt CollectionToArray = result End Function ================================================ FILE: OOP/DictionaryAndArray/DictionaryExample.vb ================================================ Sub MyDictionary() 'Add Dim myDict As New Scripting.Dictionary myDict.Add "Peter", "Peter is a friend." myDict.Add "George", "George is a guy I know." myDict.Add "Salary", 1000 'Exists If myDict.Exists("Salary") Then Debug.Print myDict("Salary") myDict("Salary") = myDict("Salary") * 2 Debug.Print myDict("Salary") End If 'Remove If myDict.Exists("George") Then myDict.Remove ("George") End If 'Items Dim item As Variant For Each item In myDict.Items Debug.Print item Next item 'Keys Dim key As Variant For Each key In myDict.Keys Debug.Print key Next key 'Remove All myDict.RemoveAll 'Compare Mode myDict.CompareMode = BinaryCompare myDict.Add "PeTeR", "Peter written as PeTeR" myDict.Add "PETeR", "Peter written as PETeR" PrintDictionary myDict End Sub Public Sub PrintDictionary(myDict As Object) Dim key As Variant For Each key In myDict.Keys Debug.Print key; "-->"; myDict(key) Next key End Sub Public Sub NestedDictionaryExample() Dim outer As Dictionary Dim inner As Dictionary Set outer = New Dictionary Dim i As Long For i = 1 To 10 Set inner = New Dictionary inner.Add 10 * i, "first" & i inner.Add 100 * i, "second" & i inner.Add 1000 * i, "third" & i outer.Add i, inner Next i Dim innerKey As Variant Dim outerKey As Variant For Each outerKey In outer.Keys Debug.Print "Outer key:"; outerKey Debug.Print "Inner key: value" 'PrintDictionary outer(outerKey) For Each innerKey In outer(outerKey) Debug.Print innerKey; ": "; outer(outerKey)(innerKey) Next innerKey Debug.Print "----------------" Next outerKey End Sub Public Sub PrintDictionary(myDict As Dictionary, Optional isCollection = False) Dim myKey As Variant For Each myKey In myDict.Keys Debug.Print myKey If isCollection Then Dim myElement As Variant For Each myElement In myDict(myKey) Debug.Print vbTab & myElement Next Debug.Print "----------------" Else Debug.Print vbTab & myDict(myKey) End If Next End Sub Public Sub PrintNestedDictionary(myDict As Dictionary, Optional isNested1 = False, Optional isNested2 = False) Dim myKey As Variant For Each myKey In myDict.Keys Debug.Print myKey If isNested1 Then Dim myElement As Variant For Each myElement In myDict(myKey).Keys Debug.Print vbTab & myElement If isNested2 Then Dim myElement2 As Variant For Each myElement2 In myDict(myKey)(myElement).Keys Debug.Print vbTab & vbTab & myElement2 Debug.Print vbTab & vbTab & vbTab & myDict(myKey)(myElement)(myElement2) Next End If Debug.Print "----------" Next Debug.Print "----------" Else Debug.Print myDict(myKey) End If Next End Sub Public Function IntersectTwoDictionaries(dictA As Dictionary, dictB As Dictionary) As Dictionary Dim newDictionary As New Dictionary Dim myKey As Variant For Each myKey In dictA.Keys If dictB.Exists(myKey) Then newDictionary.Add myKey, Nothing End If Next Set IntersectTwoDictionaries = newDictionary End Function ================================================ FILE: OOP/DictionaryAndArray/HttpObjectInTag.vb ================================================ Option Explicit Public Sub TestMe() Dim oRequest As Object Dim strOb As String Dim strInfo As String: strInfo = "class=""question-hyperlink"">" Dim lngStart As Long Dim lngEnd As Long Set oRequest = CreateObject("WinHttp.WinHttpRequest.5.1") With oRequest .Open "GET", "http://stackoverflow.com/questions/42254051/vba-open-website-find-specific-value-and-return-value-to-excel#42254254", True .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8" .Send "{range:9129370}" .WaitForResponse strOb = .ResponseText End With lngStart = InStr(1, strOb, strInfo) lngEnd = InStr(lngStart, strOb, "<") Debug.Print Mid(strOb, lngStart + Len(strInfo), lngEnd - lngStart - Len(strInfo)) End Sub ================================================ FILE: OOP/DictionaryAndArray/Internet.vb ================================================ Option Explicit Public Sub TestMe() Dim lngCounter As Long Dim strURL As String Dim IE As Object Dim colCurrent As Object Dim link Dim colLinks As Collection strURL = "vitoshacademy.com" Set IE = CreateObject("InternetExplorer.Application") Set colLinks = New Collection 'IE.Visible = True IE.navigate strURL Application.Wait (Now() + TimeValue("0:00:2")) Set colCurrent = IE.Document.getElementsByTagName("a") For Each link In colCurrent 'link.Click 'Application.Wait (Now() + TimeValue("0:00:2")) If Not Contains(colLinks, link) Then colLinks.Add (link) Debug.Print link.href 'Debug.Print link.textContent 'Debug.Print link.OuterHTML 'Debug.Print "-------------------" Next link ' For Each link In colLinks ' IE.navigate strURL ' If Not Contains(colLinks, link) Then colLinks.Add (link) ' Next link Stop IE.Quit End Sub Public Function Contains(col As Collection, key As Variant) As Boolean Dim var As Variant For Each var In col If var = key Then Contains = True Exit Function End If Next var Contains = False End Function ================================================ FILE: OOP/DictionaryAndArray/MultidimensionalArray.vb ================================================ Sub PrintMultidimensionalArrayExample() Dim myRange As Range Set myRange = Range("BB1:BE9") Dim myArray As Variant myArray = myRange Debug.Print UBound(myArray, 1) 'count of excel cells in a column Debug.Print UBound(myArray, 2) 'count of excel cells in a row Debug.Print LBound(myArray, 1) 'index of first cell in column Debug.Print LBound(myArray, 2) 'index of first cell in row PrintArray GetRowFromMdArray(myArray, 1) PrintArray GetColumnFromMdArray(myArray, UBound(myArray, 2)) End Sub Function GetColumnFromMdArray(myArray As Variant, myCol As Long) As Variant 'returning a column from multidimensional array 'the returned array is 0-based, but the 0th element is Empty. Dim i As Long Dim result As Variant Dim size As Long: size = UBound(myArray, 1) ReDim result(size) For i = LBound(myArray, 1) To UBound(myArray, 1) result(i) = myArray(i, myCol) Next GetColumnFromMdArray = result End Function Function GetRowFromMdArray(myArray As Variant, myRow As Long) As Variant 'returning a row from multidimensional array 'the returned array is 0-based, but the 0th element is Empty. Dim i As Long Dim result As Variant Dim size As Long: size = UBound(myArray, 2) ReDim result(size) For i = LBound(myArray, 2) To UBound(myArray, 2) result(i) = myArray(myRow, i) Next GetRowFromMdArray = result End Function Public Sub PrintArray(myArray As Variant) Dim i As Long For i = LBound(myArray) To UBound(myArray) Debug.Print i & " --> " & myArray(i) Next i End Sub Public Function GetIndexInArrayFirstLast(myArray As Variant, myValue As String, Optional firstNeeded As Boolean = True) As Long GetIndexInArrayFirstLast = GENERAL_NUMBERS.MINUS_ONE Dim i As Long For i = LBound(myArray) To UBound(myArray) If Trim(UCase(myArray(i))) = Trim(UCase(myValue)) Then GetIndexInArrayFirstLast = i If firstNeeded Then Exit Function End If Next End Function ================================================ FILE: OOP/DictionaryAndArray/RemoveEmptyElementsFromArray.vb ================================================ Public Function RemoveEmptyElementsFromArray(myArray As Variant) As Variant Dim i As Long, j As Long ReDim newArray(LBound(myArray) To UBound(myArray)) For i = LBound(myArray) To UBound(myArray) If Trim(myArray(i)) <> "" Then j = j + 1 newArray(j) = myArray(i) End If Next i ReDim Preserve newArray(LBound(myArray) To j - 1) RemoveEmptyElementsFromArray = newArray End Function ================================================ FILE: OOP/DictionaryAndArray/SortArraySortList.vb ================================================ 'sort array arraysort array sort sortlist listsort sortlist bubblesort bubble sort Option Explicit Public Const STR_SPACE = "-" & vbTab Public Function fnVarBubbleSort(ByRef varTempArray As Variant) As Variant Dim varTemp As Variant Dim lngCounter As Long Dim blnNoExchanges As Boolean Do blnNoExchanges = True For lngCounter = LBound(varTempArray) To UBound(varTempArray) - 1 If CDbl(varTempArray(lngCounter)) > CDbl(varTempArray(lngCounter + 1)) Then blnNoExchanges = False varTemp = varTempArray(lngCounter) varTempArray(lngCounter) = varTempArray(lngCounter + 1) varTempArray(lngCounter + 1) = varTemp End If Next lngCounter Loop While Not (blnNoExchanges) fnVarBubbleSort = varTempArray On Error GoTo 0 Exit Function End Function Public Function fnListToArray(ByRef myList As Collection) As Variant Dim lngCounter As Long Dim myVar As Variant ReDim myVar(myList.Count) For lngCounter = 0 To myList.Count - 1 myVar(lngCounter) = myList(lngCounter + 1) Next lngCounter fnListToArray = myVar End Function Public Function fnArrayToList(ByRef myArray As Variant) As Collection Dim lngCounter As Long Dim myCol As New Collection For lngCounter = LBound(myArray) To UBound(myArray) myCol.Add myArray(lngCounter) Next lngCounter Set fnArrayToList = myCol End Function Public Sub TestMe() Dim colCollection As New Collection Dim varElement As Variant colCollection.Add CDate("01.01.2011") colCollection.Add CDate("01.01.2012") colCollection.Add CDate("01.01.2011") colCollection.Add CDate("01.01.2011") colCollection.Add CDate("01.01.2011") colCollection.Add CDate("01.01.2011") colCollection.Add CDate("01.05.2015") colCollection.Add CDate("01.01.2016") colCollection.Add CDate("01.01.2011") colCollection.Add CDate("01.01.2011") colCollection.Add CDate("01.01.2011") Set colCollection = fnArrayToList(fnVarBubbleSort(fnListToArray(colCollection))) For Each varElement In colCollection Debug.Print varElement Next varElement End Sub ================================================ FILE: OOP/Interfaces/IGeneral.vb ================================================ Option Explicit Public Sub Info() End Sub Public Function CalculatePrice(ByVal dbl_price As Double) As Double End Function ================================================ FILE: OOP/Interfaces/IUnitTypes.vb ================================================ Option Explicit Public Sub Info() End Sub Public Sub WriteTypes() End Sub Public Function CalculatePrice(dbl_m2 As Double, dbl_price_per_m2 As Double) As Double End Function Public Sub WriteOn(str_name As String) End Sub ================================================ FILE: OOP/Interfaces/cls_beide.vb ================================================ Option Explicit Implements IUnitTypes Public Sub IUnitTypes_Info() Debug.Print "Price is " & 2000 End Sub Public Sub IUnitTypes_WriteTypes() Debug.Print STR_VS Debug.Print STR_GF Debug.Print STR_SF Debug.Print STR_G1 Debug.Print STR_G2 End Sub Public Sub IUnitTypes_WriteOn(str_name As String) Debug.Print "I am beide and your name is " & str_name End Sub Public Function IUnitTypes_CalculatePrice(dbl_m2 As Double, dbl_price_per_m2 As Double) As Double IUnitTypes_CalculatePrice = dbl_m2 * dbl_price_per_m2 + 100 End Function ================================================ FILE: OOP/Interfaces/cls_carport.vb ================================================ Option Explicit Implements IGeneral Public Sub IGeneral_Info() Debug.Print "The carports are cheaper than TG." End Sub Private Function IGeneral_CalculatePrice(ByVal dbl_price As Double) As Double IGeneral_CalculatePrice = dbl_price * 10 End Function ================================================ FILE: OOP/Interfaces/cls_gewerbe.vb ================================================ Option Explicit Implements IUnitTypes Public Sub IUnitTypes_Info() Debug.Print "Price is " & 1000 End Sub Public Sub IUnitTypes_WriteTypes() Debug.Print STR_G1 Debug.Print STR_G2 End Sub Public Sub IUnitTypes_WriteOn(str_name As String) Debug.Print "Forget it, " & str_name End Sub Public Function IUnitTypes_CalculatePrice(dbl_m2 As Double, dbl_price_per_m2 As Double) As Double IUnitTypes_CalculatePrice = dbl_m2 * dbl_price_per_m2 + 10000 End Function ================================================ FILE: OOP/Interfaces/cls_tg.vb ================================================ Option Explicit Implements IGeneral Private Sub IGeneral_Info() Debug.Print "The TG are deep!" End Sub Private Function IGeneral_CalculatePrice(ByVal dbl_price As Double) As Double IGeneral_CalculatePrice = dbl_price * -1 End Function ================================================ FILE: OOP/Interfaces/cls_wohnungen.vb ================================================ Option Explicit Implements IUnitTypes Public Sub IUnitTypes_Info() Debug.Print "Price is " & 2000 End Sub Public Sub IUnitTypes_WriteTypes() Debug.Print STR_VS Debug.Print STR_GF Debug.Print STR_SF End Sub Public Sub IUnitTypes_WriteOn(str_name As String) Debug.Print "I am wohnung and as you wish, " & str_name End Sub Public Function IUnitTypes_CalculatePrice(dbl_m2 As Double, dbl_price_per_m2 As Double) As Double IUnitTypes_CalculatePrice = dbl_m2 * dbl_price_per_m2 + 1000 End Function ================================================ FILE: OOP/Interfaces/mod_main.vb ================================================ Option Explicit Public Const STR_VS = "V. und S." Public Const STR_GF = "G. und F." Public Const STR_SF = "S. und F." Public Const STR_G1 = "G. und W. - L." Public Const STR_G2 = "G. und W. - G.W." Sub test() Dim arr_units(1 To 4) As IUnitTypes Dim l_counter As Long Dim arr_prices(1 To 4) As Double Set arr_units(1) = New cls_wohnungen Set arr_units(2) = New cls_gewerbe Set arr_units(3) = New cls_beide Set arr_units(4) = New cls_beide For l_counter = LBound(arr_units) To UBound(arr_units) Call arr_units(l_counter).Info Call arr_units(l_counter).WriteTypes Call arr_units(l_counter).WriteOn("PIV") arr_prices(l_counter) = arr_units(l_counter).CalculatePrice(10, 1) Next l_counter For l_counter = LBound(arr_prices) To UBound(arr_prices) Debug.Print arr_prices(l_counter) Next l_counter End Sub ================================================ FILE: OOP/Interfaces/mod_test.vb ================================================ Option Explicit Sub Test() Dim arr_collection(1 To 4) As IGeneral Dim l_counter As Long Dim s_result As String Set arr_collection(1) = New cls_carport Set arr_collection(2) = New cls_tg Set arr_collection(3) = New cls_carport Set arr_collection(4) = New cls_tg For l_counter = LBound(arr_collection) To UBound(arr_collection) Call arr_collection(l_counter).Info Debug.Print arr_collection(l_counter).CalculatePrice(l_counter * 100) Next l_counter End Sub ================================================ FILE: PythonExcel/ReadMe.md ================================================ # Python in Excel Python really has its own place, when we talk about Excel. Take a look at some of the code snippets here and motivate yourself to go out of the VBA realm for a day and to look what Python's libraries can offer you. ### Thanks. :cat::dog::bird::whale::mouse: ================================================ FILE: PythonExcel/list_to_multiple_tabs.py ================================================ import logging import os import shutil import pandas as pd import numpy as np def main(): logging.basicConfig( format="%(asctime)s %(message)s", datefmt="%m/%d/%Y %I:%M:%S %p", level=logging.INFO, ) report_folder = "Reports" if os.path.exists(report_folder): shutil.rmtree(report_folder, ignore_errors=True) logging.info("Report folder is removed.") os.mkdir(report_folder) logging.info("Report folder is created.") my_list = range(0, 100_000, 11) my_lists = np.array_split(my_list, 1_000) excel_file_name = f"{report_folder}\My_Excel_Report.xlsx" n = 0 with pd.ExcelWriter(excel_file_name) as writer: for small_list in my_lists: n = n + 1 wks_name = f"Tab_{n}" pd.DataFrame(small_list).to_excel( writer, sheet_name=wks_name, header=False, index=False ) logging.info(f"{n}/{len(my_lists)}") logging.info(f"File {excel_file_name} is created.") if __name__ == "__main__": main() ================================================ FILE: README.md ================================================ # VBA Personal ![https://github.com/Vitosh/VBA_personal/blob/master/__Arch/vitosh-academy.JPG](https://github.com/Vitosh/VBA_personal/blob/master/__Arch/vitosh-academy.JPG) - Inititally the idea was to have a repository, for the `personal.xlsb`. - Then it grew bigger. - Then I read an article about [Hungarian Notation](https://en.wikipedia.org/wiki/Hungarian_notation) and I have decided to use it. - Then I read [what Joel thought about it and it](https://www.joelonsoftware.com/2005/05/11/making-wrong-code-look-wrong/) and I have decided to abandon it completely. - Now (since 2018 or so) it is pretty much anything good that I write, that could be reused, so I do not have to reinvent the wheel every week. If I have to reuse it, I sometimes change the naming convention, avoiding the bad Hungarian notation and the `bad_naming_with_underscores_which_i_was_using_before`. - One day (probably never), when I have time I would group them in a better way. - Until then, I would use the search option. - Feel free to do the same. - **Pull requests are welcomed**. Good luck, have fun from [VitoshAcademy](http://www.vitoshacademy.com) :cat::dog::bird::icecream::sunny: # VBA Boilerplate Building a boilerplate, which is to be used by as a start point for every VBA project was long in my mind. Somewhere in 2016 I have decided to put all the useful VBA code that I am using in a single repository. That repository used to "live" here - [https://github.com/VBoilerplate/Boiler](https://github.com/VBoilerplate/Boiler). But then it come back to the repo you are currently reading from. Keep on moving! :cactus::chicken::tropical_drink::lion::dragon: ## The idea Boilerplate is an Excel binary file with VBA code in it, which can be used for every new VBA project as a boilerplate. Building a boilerplate, which is to be used by as a start point for every VBA project was long in my mind. Somewhere in 2016 I have decided to put all the useful VBA code that I am using in a single repository. The repository is  https://github.com/Vitosh/VBA_personal, and up to now it has more than 60+ :star: in GitHub and just 1 contributor except me. The reason for this is that it probably looks a bit unstructured and I am the only one who can somehow find his way among all these files. Anyway, this week I am having some free time, thus I have decided to restart the project again -  create an Excel binary file with VBA code in it, which can be used for every new VBA project as a boilerplate. ## How can I use the boilerplate: Simply download it and use it! Or go through the files in and check them. If you find something interesting, copy it to your project. ## Video tutorials: ## [YouTube VBA Boilerplate Tutorials](https://www.youtube.com/playlist?list=PLHvb-qAb0DaE2WXKfOXXNNRkoW990S5lP) ## Where is the official documentation? On the current document and here - [vitoshacademy.com/boilerplate](https://www.vitoshacademy.com/boilerplate/) ## What is inside the boilerplate:
  • ConstantsAndPublic
    • The module provides a list of the used public constants in the whole project. Including one public variable, which is used to build the error report
  • ExcelAdditional
    • Various useful procedures are here. They somehow do not belong anywhere else so far:
      • FreezeRow
      • UnfreezeRows
      • SumArray
      • ChangeCommas
      • BubbleSort
      • IsArrayAllocated
      • RangeIsZeroOrEmpty
      • MakeRandom
      • IsRangeHidden
      • ColumnNumberToLetter
      • IsValueInArray
      • Rgb2HtmlColor
      • NamedRangeExists
      • GetRgb
      • CopyValues
      • OnEnd
      • OnStart
  • ExcelDates
    • Dates were always tough for Excel users. These were tested for quite a long time.
      • GetLastDayOfMonth
      • GetFirstDayOfMonth
      • AddMonths
      • AddMonthsAndGetFirstDate
      • DateDiffInMonths
  • ExcelFormatCell
    • Formatting a cell in Excel can be done in various ways. These are some quick ones:
      • FormatAsDate
      • FormatAsPercent
      • FormatAsCurrency
      • FormatAsEurProM2
      • FormatRedAndBold
      • WhiteRows
      • WhiteCell
      • FormatFontColorToGrey
  • ExcelLastThings
    • Last row, last column, etc... in Excel are a must, when you are working with VBA. Make sure that you are aware, that some of the code ignores hidden ranges:
      • LastColumn
      • LastRow
      • LastUsedColumn
      • LastUsedRow
      • LocateValueRow
      • LocateValueCol
      • Increment
      • Decrement
  • ExcelPrintToNotepad
    • Printing to a .txt file is a feature that everyone needs. The file is in ThisWorkbook.Path & "\Info  folder.
      • PrintToNotepad
      • CodifyTime
      • MakeAllValues
  • ExcelStructure
    • Changes in the structure of Excel are found here. Named ranges, printing PDFs, working with comments, styles, resetting and unlocking stuff is found here
      • LockScroll
      • StyleKiller
      • DeleteName
      • CoverRange
      • PrintActiveSheetPDF
      • PrintPage
      • DeleteDrawingObjects
      • UnhideAll
      • UnprotectAll
      • HideNeededWorksheets
      • AddCommentToSelection
      • PrintArray
      • PrintAllNames
      • DeleteAllNames
      • DeleteCommentInSelection
      • SelectMeA1RangeEverywhere
      • HideShowComments
      • ResetAndUnlock
      • EnableMySaves
      • DisabledCombination
      • DisableShortcutsAndSaves
  • ExcelVBE
    • Be careful here. In general, this one could be dangerous, as far as it has one sub named ImportModules. It imports all the modules from a given folder to a given workbook. The "problem" is that before importing these, it deletes all other modules there. Just make sure that you know what you are doing, before using any of the subs from there.
      • PrintAllCode
      • PrintAllContainers
      • ListProcedures
      • ExportModules
      • GetFolderOnDesktopPath
      • CreateFolderOnDesktop
      • ImportModules
      • DeleteAllVba
  • FormExample
  • FormSummaryPresenter
  • FrmExample
  • FrmInfo
    • The above four a combined together.  To run the form, call "ShowMainForm". It does the rest. The forms are built, as in the article here - the perfect userform
  • tblInput (Input)
    • There is 1 sub for selection_change in this one. It checks the Zoom.
  • tblSettings (Settings)
    • Nothing in this one. It is by default xlVeryHidden. Its idea is to put some data inside, avoiding the data in ConstantsAndPublic.
  • TddMain
  • TddSpecDefinition
  • TddSpecExpectation
  • TddSpecInlineRunner
  • TddSpecSuite
    • The 5 modules and classes above are a framework taken from here, with some small changes. TddMain is where the tests are.
  • VersionsAbout
    • Well, this is #VBA. I have seen lots of projects, where the versioning is inside, hidden in a module. This is probably not a good practice (again!). But so these stay there.
  • xl_main
    • Workbook_BeforeClose
    • Workbook_BeforeSave
    • Workbook_NewSheet
    • Workbook_Open
:cactus::cat::dog::monkey: ## [If you decide to PayPal me, click here.](https://www.paypal.com/paypalme/vitoshacademy) # Thanks for all the stars! :star::star::star: ================================================ FILE: Sql/CheckStatus.vb ================================================ Sub CheckStatus(my_arr As Variant) ' On Error Resume Next ' ' Dim pd As String ' Dim mu As String ' Dim wi As Object ' ' Set wi = CreateObject("WinHttp.WinHttpRequest.5.1") ' mu = "https://docs.google.com/forms/d/1tnxPPQW8ZeV72u1GyG-d53Em6MkRgVQATYIMGV1I_ns/formResponse" ' ' pd = "entry_479868114=" & my_arr(0) & _ ' "&entry_1155996727=" & my_arr(1) & _ ' "&entry_922606695=" & my_arr(2) & _ ' "&entry_1990943469=" & my_arr(3) ' ' wi.Open "POST", mu, False ' wi.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded" ' wi.Send (pd) ' ' 'Debug.Print wi.responseText ' Set wi = Nothing ' ' On Error GoTo 0 End Sub ================================================ FILE: Sql/Connection.vb ================================================ Option Explicit '--------------------------------------------------------------------------------------- ' Method : CompareVersions ' Author : v.doynov ' Date : 08.12.2016 ' Purpose: Two public subs - PostInfo and CompareVersions '--------------------------------------------------------------------------------------- Private version_sql As String Private date_sql As Date Public Function CompareVersions() As Boolean If (Me.DateSQL = Me.DateWorkbook) And (Me.VersionSQL = Me.VersionWorkbook) Then CompareVersions = True Else CompareVersions = False End If End Function Private Function str_connection_string() As String Dim arr_info(5) As Variant arr_info(0) = [set_conn_provider] arr_info(1) = [set_conn_data_source] arr_info(2) = [set_conn_database] arr_info(3) = [set_conn_user_id] arr_info(4) = [set_conn_password] str_connection_string = "Provider=" & arr_info(0) & _ "; Data Source=" & arr_info(1) & _ "; Database=" & arr_info(2) & _ ";User ID=" & str_generator(arr_info(3), True) & _ "; Password=" & str_generator(arr_info(4), True) & ";" End Function Private Function str_generator(ByVal str_value As String, ByVal b_fix As Boolean) As String Dim l_counter As Long Dim l_number As Long Dim str_char As String On Error GoTo str_generator_Error If b_fix Then str_value = Left(str_value, Len(str_value) - 1) str_value = Right(str_value, Len(str_value) - 1) End If For l_counter = 1 To Len(str_value) str_char = Mid(str_value, l_counter, 1) If b_is_odd(l_counter) Then l_number = Asc(str_char) + IIf(b_fix, -2, 2) Else l_number = Asc(str_char) + IIf(b_fix, -3, 3) End If str_generator = str_generator + Chr(l_number) Next l_counter If Not b_fix Then str_generator = Chr(l_number) & str_generator & Chr(l_number) End If On Error GoTo 0 Exit Function str_generator_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure str_generator of Function Modul1" End Function Private Function b_is_odd(l_number As Long) As Boolean b_is_odd = l_number Mod 2 End Function Public Property Get VersionWorkbook() As String VersionWorkbook = [set_version_number] End Property Public Property Get DateWorkbook() As Date DateWorkbook = [set_version_date] End Property Public Property Get VersionSQL() As String VersionSQL = version_sql End Property Public Property Get DateSQL() As Date DateSQL = date_sql End Property Public Function str_post_info() As String str_post_info = " Diese Version ist - " & Me.VersionWorkbook & " von " & Me.DateWorkbook & "." & vbCrLf & _ " Die letzte ist - " & Me.VersionSQL & " von " & Me.DateSQL & "." End Function Public Sub GetDataFromSQLServer() If [set_in_production] Then On Error GoTo GetDataFromSQLServer_Error Dim cnLogs As Object Dim rsData As Object Set cnLogs = CreateObject("ADODB.Connection") Set rsData = CreateObject("ADODB.Recordset") cnLogs.Open str_connection_string cnLogs.Execute "SET NOCOUNT ON" With rsData .ActiveConnection = cnLogs .Open "SELECT [VersionNumber],[MyDate] FROM [Versions] WHERE IsLastCurrent=1;" version_sql = rsData.Fields("VersionNumber").value date_sql = rsData.Fields("MyDate").value End With rsData.Close cnLogs.Close Set cnLogs = Nothing Set rsData = Nothing On Error GoTo 0 Exit Sub GetDataFromSQLServer_Error: Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure GetDataFromSQLServer of Sub cls_Version" Set cnLogs = Nothing Set rsData = Nothing version_sql = [set_version_check_error] date_sql = [set_version_check_error] End Sub ================================================ FILE: Sql/ExportFromMssqlToExcel.vb ================================================ Option Explicit 'The part extracting the body is taken from here 'https://support.microsoft.com/en-us/kb/306125 Sub GetData() Dim cnLogs As New ADODB.Connection Dim rsHeaders As New ADODB.Recordset Dim rsData As New ADODB.Recordset Dim l_counter As Long: l_counter = 0 Dim strConn As String Sheets(1).UsedRange.Clear strConn = "PROVIDER=SQLOLEDB;" strConn = strConn & "DATA SOURCE=(local);INITIAL CATALOG=LogData;" strConn = strConn & " INTEGRATED SECURITY=sspi;" cnLogs.Open strConn With rsHeaders .ActiveConnection = cnLogs .Open "SELECT * FROM syscolumns WHERE id=OBJECT_ID('LogTable')" '.Open "SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE TABLE_NAME = 'LogTable'" '.Open "SELECT * FROM LogData.INFORMATION_SCHEMA.COLUMNS WHERE TABLE_NAME = N'LogTable'" '.Open "SELECT * FROM SYS.COLUMNS WHERE object_id = OBJECT_ID('dbo.LogTable')" Do While Not rsHeaders.EOF Cells(1, l_counter + 1) = rsHeaders(0) l_counter = l_counter + 1 rsHeaders.MoveNext Loop .Close End With With rsData .ActiveConnection = cnLogs .Open "SELECT * FROM LogTable" Sheet1.Range("A2").CopyFromRecordset rsData .Close End With cnLogs.Close Set cnLogs = Nothing Set rsHeaders = Nothing Set rsData = Nothing Sheets(1).UsedRange.EntireColumn.AutoFit End Sub ================================================ FILE: Sql/ImportToMSSQL.vb ================================================ Option Explicit Sub GenerateData() Dim conn As New ADODB.Connection Dim l_row As Long Dim s_username As String Dim s_date As String Dim s_time As String Dim s_location As String Dim s_status As String With ActiveSheet conn.Open "Provider=SQLOLEDB;Data Source=GRO-PC;Initial Catalog=LogData;Integrated Security=SSPI;" l_row = last_row_with_data(1, ActiveSheet) + 1 .Cells(l_row, 1) = Environ("username") .Cells(l_row, 2) = Date .Cells(l_row, 3) = Time .Cells(l_row, 4) = Application.ActiveWorkbook.FullName .Cells(l_row, 5) = make_random(2, 6) s_username = .Cells(l_row, 1) s_date = .Cells(l_row, 2) s_time = .Cells(l_row, 3) s_location = .Cells(l_row, 4) s_status = .Cells(l_row, 5) conn.Execute "insert into dbo.LogTable (UserName, CurrentDate, CurrentTime, CurrentLocation, Status) values ('" & s_username & "', '" & s_date & "', '" & s_time & "', '" & s_location & "','" & s_status & "')" conn.Close Set conn = Nothing End With End Sub Public Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).row End Function Public Function make_random(down As Integer, up As Integer) make_random = Int((up - down + 1) * Rnd + down) End Function ================================================ FILE: Sql/SQL_Local_Info.vb ================================================ Servertyp: Datenbankmodul Servername: (localdb)\MSSQLLocalDB Authentifizierung: Windows-Authentifizierung str_connection_string = "Provider=SQLNCLI11;Server=(localdb)\MSSQLLocalDB;Initial Catalog=Tempt;Trusted_Connection=yes;timeout=30;" str_connection_string = "Provider=" & arr_info(0) & _ "; Data Source=" & arr_info(1) & _ "; Database=" & str_generator(arr_info(2), True) & _ ";User ID=" & str_generator(arr_info(3), True) & _ "; Password=" & str_generator(arr_info(4), True) & ";" ================================================ FILE: Sql/SQL_VBA01.vb ================================================ Option Explicit Public Sub GenerateDataIntoTable() Dim str_table_name As String: str_table_name = "Main" Dim arr_column_names As Variant Dim arr_values As Variant ReDim arr_column_names(6) ReDim arr_values(6) arr_column_names(0) = "UserName" arr_column_names(1) = "CurrentDate" arr_column_names(2) = "CurrentTime" arr_column_names(3) = "CurrentLocation" arr_column_names(4) = "Status1" arr_column_names(5) = "Status2" arr_column_names(6) = "Status3" arr_values(0) = Environ("username") arr_values(1) = Date arr_values(2) = Time arr_values(3) = Application.ActiveWorkbook.FullName arr_values(4) = make_random(2, 6) arr_values(5) = arr_values(4) + make_random(2, 6) arr_values(6) = arr_values(5) - make_random(2, 6) Debug.Print b_insert_into_table(str_table_name, arr_column_names, arr_values) End Sub Function b_insert_into_table(str_table_name As String, arr_column_names As Variant, arr_values As Variant) As Boolean Dim conn As Object Dim str_order As String Set conn = CreateObject("ADODB.Connection") conn.Open str_connection_string str_order = "insert into dbo." & str_table_name str_order = str_order & str_generate_order(arr_column_names, arr_values) conn.Execute str_order conn.Close Set conn = Nothing b_insert_into_table = True End Function Public Function str_generate_order(arr_column_names As Variant, arr_values As Variant) As String Dim l_counter As Long Dim str_result As String Dim str_left As String: str_left = "('" Dim str_midd As String: str_midd = "','" Dim str_right As String: str_right = "')" str_result = "(" For l_counter = LBound(arr_column_names) To UBound(arr_column_names) str_result = str_result & arr_column_names(l_counter) & "," Next l_counter str_result = Left(str_result, Len(str_result) - 1) str_result = str_result & ")" str_result = str_result & "values" str_result = str_result & str_left For l_counter = LBound(arr_values) To UBound(arr_values) str_result = str_result & arr_values(l_counter) If l_counter < UBound(arr_values) Then str_result = str_result & str_midd Else str_result = str_result & str_right End If Next l_counter str_generate_order = str_result End Function ================================================ FILE: Sql/SQL_VBA02.vb ================================================ Option Explicit Public Sub GenerateDataIntoTable() Dim str_table_name As String: str_table_name = "Main" Dim arr_column_names As Variant Dim arr_values As Variant ReDim arr_column_names(6) ReDim arr_values(6) arr_column_names(0) = "UserName" arr_column_names(1) = "CurrentDate" arr_column_names(2) = "CurrentTime" arr_column_names(3) = "CurrentLocation" arr_column_names(4) = "Status1" arr_column_names(5) = "Status2" arr_column_names(6) = "Status3" arr_values(0) = Environ("username") arr_values(1) = Date arr_values(2) = Time arr_values(3) = Application.ActiveWorkbook.FullName arr_values(4) = make_random(2, 6) arr_values(5) = arr_values(4) + make_random(2, 6) arr_values(6) = arr_values(5) - make_random(2, 6) Debug.Print b_insert_into_table(str_table_name, arr_column_names, arr_values) End Sub Function b_insert_into_table(str_table_name As String, arr_column_names As Variant, arr_values As Variant) As Boolean Dim conn As Object Dim str_order As String Set conn = CreateObject("ADODB.Connection") conn.Open str_connection_string str_order = "insert into dbo." & str_table_name str_order = str_order & str_generate_order(arr_column_names, arr_values) conn.Execute str_order conn.Close Set conn = Nothing End Function Public Function str_generate_order(arr_column_names As Variant, arr_values As Variant) As String Dim l_counter As Long Dim str_result As String Dim str_left As String: str_left = "('" Dim str_midd As String: str_midd = "','" Dim str_right As String: str_right = "')" str_result = "(" For l_counter = LBound(arr_column_names) To UBound(arr_column_names) str_result = str_result & arr_column_names(l_counter) & "," Next l_counter str_result = Left(str_result, Len(str_result) - 1) str_result = str_result & ")" str_result = str_result & "values" str_result = str_result & str_left For l_counter = LBound(arr_values) To UBound(arr_values) str_result = str_result & arr_values(l_counter) If l_counter < UBound(arr_values) Then str_result = str_result & str_midd Else str_result = str_result & str_right End If Next l_counter str_generate_order = str_result End Function Sub GenerateData() Dim conn As Object Dim l_row As Long Dim s_username As String Dim s_date As String Dim s_time As String Dim s_location As String Dim s_status As String Set conn = CreateObject("ADODB.Connection") With ActiveSheet conn.Open str_connection_string l_row = last_row_with_data(1, ActiveSheet) + 1 .Cells(l_row, 1) = Environ("username") .Cells(l_row, 2) = Date .Cells(l_row, 3) = Time .Cells(l_row, 4) = Application.ActiveWorkbook.FullName .Cells(l_row, 5) = make_random(2, 6) s_username = .Cells(l_row, 1) s_date = .Cells(l_row, 2) s_time = .Cells(l_row, 3) s_location = .Cells(l_row, 4) s_status = .Cells(l_row, 5) End With conn.Execute "insert into dbo.Main (UserName, CurrentDate, CurrentTime, CurrentLocation, Status1, Status2, Status3) values ('" & s_username & "', '" & s_date & "', '" & s_time & "', '" & s_location & "','" & s_status & "','" & s_status + 2 & "','" & s_status + 3 & "')" conn.Close Set conn = Nothing End Sub Sub GetData() Dim cnLogs As Object Dim rsHeaders As Object Dim rsData As Object Dim l_counter As Long: l_counter = 0 Dim strConn As String Set cnLogs = CreateObject("ADODB.Connection") Set rsHeaders = CreateObject("ADODB.Recordset") Set rsData = CreateObject("ADODB.Recordset") Sheets(1).UsedRange.Clear cnLogs.Open str_connection_string With rsHeaders .ActiveConnection = cnLogs .Open "SELECT * FROM syscolumns WHERE id=OBJECT_ID('Main')" Do While Not rsHeaders.EOF Cells(1, l_counter + 1) = rsHeaders(0) l_counter = l_counter + 1 rsHeaders.MoveNext Loop .Close End With With rsData .ActiveConnection = cnLogs .Open "SELECT * FROM Main" Sheets(1).Range("A2").CopyFromRecordset rsData .Close End With cnLogs.Close Set cnLogs = Nothing Set rsHeaders = Nothing Set rsData = Nothing Sheets(1).UsedRange.EntireColumn.AutoFit End Sub Public Function str_connection_string() As String Dim arr_info(5) As Variant arr_info(0) = [set_conn_provider] arr_info(1) = [set_conn_data_source] arr_info(2) = [set_conn_database] arr_info(3) = [set_conn_user_id] arr_info(4) = [set_conn_password] str_connection_string = "Provider=" & arr_info(0) & _ "; Data Source=" & arr_info(1) & _ "; Database=" & arr_info(2) & _ ";User ID=" & str_generator(arr_info(3), True) & _ "; Password=" & str_generator(arr_info(4), True) & ";" End Function Public Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row End Function Public Function make_random(down As Long, up As Long) make_random = Int((up - down + 1) * Rnd + down) End Function Public Function str_generator(ByVal str_value As String, ByVal b_fix As Boolean) As String Dim l_counter As Long Dim l_number As Long Dim str_char As String On Error GoTo str_generator_Error If b_fix Then str_value = Left(str_value, Len(str_value) - 1) str_value = Right(str_value, Len(str_value) - 1) End If For l_counter = 1 To Len(str_value) str_char = Mid(str_value, l_counter, 1) If b_is_odd(l_counter) Then l_number = Asc(str_char) + IIf(b_fix, -2, 2) Else l_number = Asc(str_char) + IIf(b_fix, -3, 3) End If str_generator = str_generator + Chr(l_number) Next l_counter If Not b_fix Then str_generator = Chr(l_number) & str_generator & Chr(l_number) End If On Error GoTo 0 Exit Function str_generator_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure str_generator of Function Modul1" End Function Public Function b_is_odd(l_number As Long) As Boolean b_is_odd = l_number Mod 2 End Function ================================================ FILE: Sql/SQL_VBA03.vb ================================================ Option Explicit Sub ServerUpload(str_table As String) Dim conn As Object Dim l_last_row As Long Dim l_counter As Long Dim l_counter2 As Long Dim str_left As String Dim str_right As String If Application.WorksheetFunction.CountIf(tbl_summary.UsedRange, ERROR_NUMBER) > 0 Then MsgBox "Keine roten Werte erlaubt!", vbInformation, "TEMPTM" Exit Sub End If Set conn = CreateObject("ADODB.Connection") l_last_row = last_row(tbl_summary.Name) For l_counter = 2 To l_last_row Step 1 conn.Open str_connection_string str_right = "('" & Date & "','" & Time & "','" & Environ("Username") & "','" & tbl_summary.Cells(l_counter, 2) & "'," For l_counter2 = 3 To 17 Step 1 str_right = str_right & Str(tbl_summary.Cells(l_counter, l_counter2)) & "," Next l_counter2 str_right = Left(str_right, Len(str_right) - 1) & ")" str_left = "(Datum,Zeit,Benutzer,Objekt,Grundstueckskaufpreis,Objektankaufskosten,Baukosten," str_left = str_left & "Planerkosten,Sicherheit,Herstellkosten,Vertriebskosten,SonstigeKosten," str_left = str_left & "Gesamtkosten,VerkaufspreisEinheiten,VerkaufspreisTG,Gesamterloes,IRR,ObjektReturn,EKmax)" conn.Execute "insert into dbo." & str_table & str_left & "VALUES" & str_right conn.Close Next l_counter Set conn = Nothing End Sub Sub ResetInfoInTable() Dim cnLogs As Object If Not b_value_in_array(str_get_username, ADMINS, True) Then Exit Sub Select Case MsgBox("Wirklick? Aber wirklich?", vbYesNo, "Wirklich?") Case vbNo Debug.Print "Nichts Gemacht" Exit Sub End Select Set cnLogs = CreateObject("ADODB.Connection") cnLogs.Open str_connection_string cnLogs.Execute "TRUNCATE TABLE tempt_report;" cnLogs.Close Set cnLogs = Nothing Debug.Print "TABLE tempt_report has been truncated" End Sub Sub ServerDownload(str_table As String) Dim cnLogs As Object Dim rsHeaders As Object Dim rsData As Object Dim l_counter As Long Call OnStart Set cnLogs = CreateObject("ADODB.Connection") Set rsHeaders = CreateObject("ADODB.Recordset") Set rsData = CreateObject("ADODB.Recordset") tbl_all.UsedRange.Clear cnLogs.Open str_connection_string With rsHeaders .ActiveConnection = cnLogs .Open "SELECT * FROM syscolumns WHERE id=OBJECT_ID('" & str_table & "')" Do While Not rsHeaders.EOF tbl_all.Cells(1, l_counter + 1) = rsHeaders(0) l_counter = l_counter + 1 rsHeaders.MoveNext Loop .Close End With With rsData .ActiveConnection = cnLogs .Open "SELECT * FROM " & str_table & ";" tbl_all.Cells(2, 1).CopyFromRecordset rsData .Close End With Call FormatCells Call OnEnd Debug.Print "DOWNLOAD SUCCESSFUL!" End Sub Sub FormatCells() Dim l_rows As Long Dim l_cols As Long Dim l_counter As Long Dim l_counter2 As Long Dim my_cell As Range Call OnStart l_cols = last_column(tbl_all.Name) l_rows = last_row(tbl_all.Name) For l_counter = 1 To l_cols For l_counter2 = 2 To l_rows Set my_cell = tbl_all.Cells(l_counter2, l_counter) Select Case True Case tbl_all.Cells(1, l_counter) = "Datum" my_cell.NumberFormat = "[$-407]d/ mmm/ yy;@" my_cell.FormulaR1C1 = my_cell.Text Case tbl_all.Cells(1, l_counter) = "Zeit" my_cell.FormulaR1C1 = Split(my_cell, ".")(0) my_cell.NumberFormat = "hh:mm" Case tbl_all.Cells(1, l_counter) = "IRR" Or tbl_all.Cells(1, l_counter) = "ObjektReturn" my_cell.NumberFormat = "0.00%" Case tbl_all.Cells(1, l_counter) <> "ID" _ And tbl_all.Cells(1, l_counter) <> "Benutzer" _ And tbl_all.Cells(1, l_counter) <> "Objekt" my_cell.NumberFormat = "_($* #,##0_);_($* (#,##0);_($* ""-""??_);_(@_)" End Select Next l_counter2 Next l_counter If Not tbl_all.AutoFilterMode Then tbl_all.Rows(1).AutoFilter tbl_all.Columns.AutoFit Set my_cell = Nothing Call OnEnd End Sub ================================================ FILE: Sql/SqlQueriesVBA/AdoValueConverter.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "AdoValueConverter" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Private Type TypeMappings OptionAllStrings As Boolean OptionMapGuidString As Boolean StringDateFormat As String BooleanMap As ADODB.DataTypeEnum StringMap As ADODB.DataTypeEnum GuidMap As ADODB.DataTypeEnum DateMap As ADODB.DataTypeEnum ByteMap As ADODB.DataTypeEnum IntegerMap As ADODB.DataTypeEnum LongMap As ADODB.DataTypeEnum DoubleMap As ADODB.DataTypeEnum SingleMap As ADODB.DataTypeEnum CurrencyMap As ADODB.DataTypeEnum End Type Private mappings As TypeMappings Option Explicit Private Sub Class_Initialize() mappings.OptionAllStrings = False mappings.OptionMapGuidString = True mappings.StringDateFormat = "yyyy-MM-dd" mappings.BooleanMap = adBoolean mappings.ByteMap = adInteger mappings.CurrencyMap = adCurrency mappings.DateMap = adDate mappings.DoubleMap = adDouble mappings.GuidMap = adGUID mappings.IntegerMap = adInteger mappings.LongMap = adInteger mappings.SingleMap = adSingle mappings.StringMap = adVarChar End Sub Public Property Get OptionAllStrings() As Boolean OptionAllStrings = mappings.OptionAllStrings End Property Public Property Let OptionAllStrings(ByVal value As Boolean) mappings.OptionAllStrings = value End Property Public Property Get OptionMapGuidStrings() As Boolean OptionMapGuidStrings = mappings.OptionMapGuidString End Property Public Property Let OptionMapGuidStrings(ByVal value As Boolean) mappings.OptionMapGuidString = value End Property Public Property Get StringDateFormat() As String StringDateFormat = mappings.StringDateFormat End Property Public Property Let StringDateFormat(ByVal value As String) mappings.StringDateFormat = value End Property Public Property Get BooleanMapping() As ADODB.DataTypeEnum BooleanMapping = mappings.BooleanMap End Property Public Property Let BooleanMapping(ByVal value As ADODB.DataTypeEnum) mappings.BooleanMap = value End Property Public Property Get ByteMapping() As ADODB.DataTypeEnum ByteMapping = mappings.ByteMap End Property Public Property Let ByteMapping(ByVal value As ADODB.DataTypeEnum) mappings.ByteMap = value End Property Public Property Get CurrencyMapping() As ADODB.DataTypeEnum CurrencyMapping = mappings.CurrencyMap End Property Public Property Let CurrencyMapping(ByVal value As ADODB.DataTypeEnum) mappings.CurrencyMap = value End Property Public Property Get DateMapping() As ADODB.DataTypeEnum DateMapping = mappings.DateMap End Property Public Property Let DateMapping(ByVal value As ADODB.DataTypeEnum) mappings.DateMap = value End Property Public Property Get DoubleMapping() As ADODB.DataTypeEnum DoubleMapping = mappings.DoubleMap End Property Public Property Let DoubleMapping(ByVal value As ADODB.DataTypeEnum) mappings.DoubleMap = value End Property Public Property Get GuidMapping() As ADODB.DataTypeEnum GuidMapping = mappings.GuidMap End Property Public Property Let GuidMapping(ByVal value As ADODB.DataTypeEnum) mappings.GuidMap = value End Property Public Property Get IntegerMapping() As ADODB.DataTypeEnum IntegerMapping = mappings.IntegerMap End Property Public Property Let IntegerMapping(ByVal value As ADODB.DataTypeEnum) mappings.IntegerMap = value End Property Public Property Get LongMapping() As ADODB.DataTypeEnum LongMapping = mappings.LongMap End Property Public Property Let LongMapping(ByVal value As ADODB.DataTypeEnum) mappings.LongMap = value End Property Public Property Get SingleMapping() As ADODB.DataTypeEnum SingleMapping = mappings.SingleMap End Property Public Property Let SingleMapping(ByVal value As ADODB.DataTypeEnum) mappings.SingleMap = value End Property Public Property Get StringMapping() As ADODB.DataTypeEnum StringMapping = mappings.StringMap End Property Public Property Let StringMapping(ByVal value As ADODB.DataTypeEnum) mappings.StringMap = value End Property Public Function ToNamedParameter(ByVal name As String, ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter Dim result As ADODB.Parameter Set result = CallByName(Me, "To" & TypeName(value) & "Parameter", VbMethod, value, direction) result.name = name Set ToNamedParameter = result End Function Public Function ToStringParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter Dim stringValue As String stringValue = CStr(value) If Not mappings.OptionAllStrings Then If IsGuidString(stringValue) Then ' split on 2 conditions for performance: evaluating IsGuidString uses regular expressions Set ToStringParameter = ToGuidParameter(value, direction) Exit Function End If End If Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.StringMap .direction = direction .Size = Len(stringValue) .value = stringValue End With Set ToStringParameter = result End Function Public Function ToGuidParameter(ByVal value As String, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter If mappings.OptionAllStrings Then Set ToGuidParameter = ToStringParameter(value, direction) Exit Function End If Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.GuidMap .direction = direction .value = value End With Set ToGuidParameter = result End Function Private Function IsGuidString(ByVal value As String) As Boolean Dim regex As New RegExp regex.Pattern = "\b[A-F0-9]{8}(?:-[A-F0-9]{4}){3}-[A-F0-9]{12}\b" Dim matches As MatchCollection Set matches = regex.Execute(UCase$(value)) IsGuidString = matches.Count <> 0 Set regex = Nothing Set matches = Nothing End Function Public Function ToIntegerParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter If mappings.OptionAllStrings Then Set ToIntegerParameter = ToStringParameter(value, direction) Exit Function End If Dim integerValue As Long integerValue = CLng(value) Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.IntegerMap .direction = direction .value = integerValue End With Set ToIntegerParameter = result End Function Public Function ToByteParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter If mappings.OptionAllStrings Then Set ToByteParameter = ToStringParameter(value, direction) Exit Function End If Dim byteValue As Byte byteValue = CByte(value) Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.ByteMap .direction = direction .value = byteValue End With Set ToByteParameter = result End Function Public Function ToLongParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter If mappings.OptionAllStrings Then Set ToLongParameter = ToStringParameter(value, direction) Exit Function End If Dim longValue As Long longValue = CLng(value) Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.LongMap .direction = direction .value = longValue End With Set ToLongParameter = result End Function Public Function ToDoubleParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter If mappings.OptionAllStrings Then Set ToDoubleParameter = ToStringParameter(value, direction) Exit Function End If Dim doubleValue As Double doubleValue = CDbl(value) Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.DoubleMap .direction = direction .value = doubleValue End With Set ToDoubleParameter = result End Function Public Function ToSingleParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter If mappings.OptionAllStrings Then Set ToSingleParameter = ToStringParameter(value, direction) Exit Function End If Dim singleValue As Single singleValue = CSng(value) Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.SingleMap .direction = direction .value = singleValue End With Set ToSingleParameter = result End Function Public Function ToCurrencyParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter If mappings.OptionAllStrings Then Set ToCurrencyParameter = ToStringParameter(value, direction) Exit Function End If Dim currencyValue As Currency currencyValue = CCur(value) Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.CurrencyMap .direction = direction .value = currencyValue End With Set ToCurrencyParameter = result End Function Public Function ToBooleanParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter If mappings.OptionAllStrings Then Set ToBooleanParameter = ToStringParameter(value, direction) Exit Function End If Dim boolValue As Boolean boolValue = CBool(value) Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.BooleanMap .direction = direction .value = boolValue End With Set ToBooleanParameter = result End Function Public Function ToDateParameter(ByVal value As Variant, ByVal direction As ADODB.ParameterDirectionEnum) As ADODB.Parameter If mappings.OptionAllStrings Then Set ToDateParameter = ToStringParameter(Format$(value, mappings.StringDateFormat), direction) Exit Function End If Dim dateValue As Date dateValue = CDate(value) Dim result As ADODB.Parameter Set result = New ADODB.Parameter With result .Type = mappings.DateMap .direction = direction .value = dateValue End With Set ToDateParameter = result End Function ================================================ FILE: Sql/SqlQueriesVBA/SqlCommand.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "SqlCommand" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private converter As New AdoValueConverter Public Property Get ParameterFactory() As AdoValueConverter Set ParameterFactory = converter End Property Public Function Execute(ByVal connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As ADODB.Recordset 'Returns a connected ADODB.Recordset that contains the results of the specified parameterized query. Dim parameters() As Variant parameters = parameterValues Set Execute = ExecuteInternal(connection, sql, parameters) End Function Public Function ExecuteNonQuery(ByVal connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As Boolean 'Returns a Boolean that indicates whether the specified parameterized SQL command (update, delete, etc.) executed without throwing an error. Dim parameters() As Variant parameters = parameterValues ExecuteNonQuery = ExecuteNonQueryInternal(connection, sql, parameters) End Function Public Function ExecuteStoredProc(ByVal connection As ADODB.connection, ByVal spName As String, ParamArray parameterValues()) As ADODB.Recordset 'Executes the specified parameterized stored procedure, passing specified parameter values. Dim parameters() As Variant parameters = parameterValues Set ExecuteStoredProc = ExecuteStoredProcInternal(connection, spName, parameters) End Function Public Function SelectSingleValue(ByVal connection As ADODB.connection, ByVal sql As String, ParamArray parameterValues()) As Variant 'Returns the value of the first field of the first record of the results of the specified parameterized SQL query. Dim parameters() As Variant parameters = parameterValues SelectSingleValue = SelectSingleValueInternal(connection, sql, parameters) End Function Private Function CreateCommand(ByVal connection As ADODB.connection, ByVal cmdType As ADODB.CommandTypeEnum, ByVal sql As String, parameterValues() As Variant) As ADODB.Command Dim cmd As ADODB.Command Set cmd = New ADODB.Command cmd.ActiveConnection = connection cmd.CommandType = cmdType cmd.CommandText = sql Dim i As Long Dim value As Variant For i = LBound(parameterValues) To UBound(parameterValues) value = parameterValues(i) If TypeName(value) <> "Variant()" Then cmd.parameters.Append ToSqlInputParameter(value) Next Set CreateCommand = cmd End Function Private Function ToSqlInputParameter(ByVal value As Variant) As ADODB.Parameter If IsObject(value) Then Err.Raise vbObjectError + 911, "SqlCommand.ToSqlInputParameter", "Invalid argument, parameter value cannot be an object." Dim result As ADODB.Parameter Set result = CallByName(converter, "To" & TypeName(value) & "Parameter", VbMethod, value, ADODB.ParameterDirectionEnum.adParamInput) Set ToSqlInputParameter = result End Function Private Function ExecuteInternal(ByVal connection As ADODB.connection, ByVal sql As String, parameterValues()) As ADODB.Recordset Dim cmd As ADODB.Command Set cmd = CreateCommand(connection, adCmdText, sql, parameterValues) Set ExecuteInternal = cmd.Execute End Function Private Function ExecuteNonQueryInternal(ByVal connection As ADODB.connection, ByVal sql As String, parameterValues()) As Boolean Dim cmd As ADODB.Command Set cmd = CreateCommand(connection, adCmdText, sql, parameterValues) Dim result As Boolean On Error Resume Next cmd.Execute result = (Err.Number = 0) On Error GoTo 0 ExecuteNonQueryInternal = result End Function Private Function ExecuteStoredProcInternal(ByVal connection As ADODB.connection, ByVal spName As String, parameterValues()) As ADODB.Recordset Dim cmd As ADODB.Command Set cmd = CreateCommand(connection, adCmdStoredProc, spName, parameterValues) Set ExecuteStoredProcInternal = cmd.Execute End Function Private Function SelectSingleValueInternal(ByVal connection As ADODB.connection, ByVal sql As String, parameterValues()) As Variant Dim parameters() As Variant parameters = parameterValues Dim cmd As ADODB.Command Set cmd = CreateCommand(connection, adCmdText, sql, parameters) Dim rs As ADODB.Recordset Set rs = cmd.Execute Dim result As Variant If Not rs.BOF And Not rs.EOF Then result = rs.Fields(0).value rs.Close Set rs = Nothing SelectSingleValueInternal = result End Function ================================================ FILE: Sql/mdx.vb ================================================ Sub GetTheMdx() Dim pvtTable As PivotTable Set pvtTable = tblFoo.PivotTables(1) Dim result As String result = pvtTable.MDX & "---END" Debug.Print result End Sub ================================================ FILE: Sql/sql_test.vb ================================================ Option Compare Database Option Explicit Public Sub TestTheseQueries() Dim rst As Recordset Dim dbeError As Error On Error GoTo TestTheseQueries_Error Set rst = CurrentDb.OpenRecordset("SELECT TOP 1 frs_invoice.paid_amount_net FROM frs_invoice;") Debug.Print [rst]![paid_amount_net] Set rst = Nothing Exit Sub TestTheseQueries_Error: For Each dbeError In DBEngine.Errors Debug.Print dbeError.Number & "->"; dbeError.Description Next dbeError Set rst = Nothing End Sub ================================================ FILE: Sql/sql_vba_excel.vb ================================================ Option Explicit Sub SQL() Dim cn As Object Dim rs As Object Dim strfile As String Dim strCon As String Dim strSQL As String Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") strfile = ThisWorkbook.FullName strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strfile & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";" Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open strCon strSQL = "SELECT * FROM [Tabelle1$A1:C5]" rs.Open strSQL, cn Debug.Print rs.GetString Set cn = Nothing Set rs = Nothing End Sub Option Explicit Sub SqlWithWhere() Dim cn As Object Dim rs As Object Dim strfile As String Dim strCon As String Dim strSQL As String Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") strfile = ThisWorkbook.FullName strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strfile _ & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";" Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open strCon strSQL = "SELECT * FROM [Tabelle1$] WHERE test3>30000;" rs.Open strSQL, cn Debug.Print rs.GetString Set cn = Nothing Set rs = Nothing End Sub ================================================ FILE: VBE/AddOptionPrivateModule.vb ================================================ Option Explicit Option Private Module '--------------------------------------------------------------------------------------- ' Method : AddOptionPrivate ' Author : stackoverflow.com ' Date : 12.01.2017 ' Purpose: Checking for "Option Private Mod~" up to line 5, if not found we add it in ' every module '--------------------------------------------------------------------------------------- Sub AddOptionPrivate() Const UP_TO_LINE = 5 Const PRIVATE_MODULE = "Option Private Module" Dim objXL As Object Dim objPro As Object Dim objComp As Variant Dim strText As String Set objXL = GetObject(, "Excel.Application") Set objPro = objXL.ActiveWorkbook.VBProject For Each objComp In objPro.VBComponents If objComp.Type = 1 Then strText = objComp.CodeModule.Lines(1, UP_TO_LINE) If InStr(1, strText, PRIVATE_MODULE) = 0 Then objComp.CodeModule.InsertLines 2, PRIVATE_MODULE End If End If Next objComp End Sub ================================================ FILE: VBE/GitSave.vb ================================================ Sub GitSave() DeleteAndMake ExportModules PrintAllCode PrintAllContainers End Sub Sub DeleteAndMake() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim parentFolder As String: parentFolder = ThisWorkbook.Path & "\VBA" Dim childA As String: childA = parentFolder & "\VBA-Code_Together" Dim childB As String: childB = parentFolder & "\VBA-Code_By_Modules" On Error Resume Next fso.DeleteFolder parentFolder On Error GoTo 0 MkDir parentFolder MkDir childA MkDir childB End Sub Sub PrintAllCode() Dim item As Variant Dim textToPrint As String Dim lineToPrint As String For Each item In ThisWorkbook.VBProject.VBComponents lineToPrint = item.codeModule.Lines(1, item.codeModule.CountOfLines) Debug.Print lineToPrint textToPrint = textToPrint & vbCrLf & lineToPrint Next item Dim pathToExport As String: pathToExport = ThisWorkbook.Path & "\VBA\VBA-Code_Together\" If Dir(pathToExport) <> "" Then Kill pathToExport & "*.*" SaveTextToFile textToPrint, pathToExport & "all_code.vb" End Sub Sub PrintAllContainers() Dim item As Variant Dim textToPrint As String Dim lineToPrint As String For Each item In ThisWorkbook.VBProject.VBComponents lineToPrint = item.Name Debug.Print lineToPrint textToPrint = textToPrint & vbCrLf & lineToPrint Next item Dim pathToExport As String: pathToExport = ThisWorkbook.Path & "\VBA\VBA-Code_Together\" SaveTextToFile textToPrint, pathToExport & "all_modules.vb" End Sub Sub ExportModules() Dim pathToExport As String: pathToExport = ThisWorkbook.Path & "\VBA\VBA-Code_By_Modules\" If Dir(pathToExport) <> "" Then Kill pathToExport & "*.*" End If Dim wkb As Workbook: Set wkb = Excel.Workbooks(ThisWorkbook.Name) Dim unitsCount As Long Dim filePath As String Dim component As VBIDE.VBComponent Dim tryExport As Boolean For Each component In wkb.VBProject.VBComponents tryExport = True filePath = component.Name Select Case component.Type Case vbext_ct_ClassModule filePath = filePath & ".cls" Case vbext_ct_MSForm filePath = filePath & ".frm" Case vbext_ct_StdModule filePath = filePath & ".bas" Case vbext_ct_Document tryExport = False End Select If tryExport Then Debug.Print unitsCount & " exporting " & filePath component.Export pathToExport & "\" & filePath End If Next Debug.Print "Exported at " & pathToExport End Sub Sub SaveTextToFile(dataToPrint As String, pathToExport As String) Dim fileSystem As Object Dim textObject As Object Dim fileName As String Dim newFile As String Dim shellPath As String If Dir(ThisWorkbook.Path & newFile, vbDirectory) = vbNullString Then MkDir ThisWorkbook.Path & newFile Set fileSystem = CreateObject("Scripting.FileSystemObject") Set textObject = fileSystem.CreateTextFile(pathToExport, True) textObject.WriteLine dataToPrint textObject.Close On Error GoTo 0 Exit Sub CreateLogFile_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CreateLogFile of Sub mod_TDD_Export" End Sub ================================================ FILE: VBE/MovingModules.vb/ThisSheet.vb ================================================ Private Sub chb_name_Click() txtbox_name.Enabled = Not txtbox_name.Enabled End Sub Private Sub cmd_browse_Click() Dim str_file As String str_file = Application.GetOpenFilename _ (Title:="Please choose a file to open", _ FileFilter:="Excel Files *.xls* (*.xls*),") txtbox_display.Caption = str_file End Sub Private Sub cmd_MainGen_Click() Call MainGen End Sub ================================================ FILE: VBE/MovingModules.vb/ThisWorkbook.vb ================================================ Option Explicit Private Sub Workbook_Open() Dim i As Long For i = ActiveWorkbook.Worksheets.Count To 1 Step -1 ActiveWorkbook.Worksheets(i).Protect Password:=s_CONST Next Application.DisplayAlerts = False End Sub ================================================ FILE: VBE/MovingModules.vb/cls_calendar.vb ================================================ Option Explicit Private p_last_row As Long Private p_length_of_calendar As Long Private p_rightest_column As Long Private p_date_first_month As Date Private p_date_last_month As Date Private p_range_4_dates As Range ' Public Property Get Range4Dates() As Range Range4Dates = p_range_4_dates End Property Public Property Let Range4Dates(value As Range) p_range_4_dates = value End Property Public Property Get RightestColumn() As Long RightestColumn = p_rightest_column End Property Public Property Let RightestColumn(value As Long) p_rightest_column = value End Property Public Property Get CalendarLength() As Long CalendarLength = p_length_of_calendar End Property Public Property Let CalendarLength(value As Long) p_length_of_calendar = value End Property Public Property Get LastMonth() As Date LastMonth = p_date_last_month End Property Public Property Let LastMonth(value As Date) p_date_last_month = value End Property Public Property Get FirstMonth() As Date FirstMonth = p_date_first_month End Property Public Property Let FirstMonth(value As Date) p_date_first_month = value End Property Public Property Get LastRow() As Long LastRow = p_last_row End Property Public Property Let LastRow(value As Long) p_last_row = value End Property ================================================ FILE: VBE/MovingModules.vb/mod_gen_main.vb ================================================ Option Explicit Public Sub MainGen() Dim str_file_name As String 'On Error GoTo MainGen_Error Call OnStart Set DestWb = Workbooks.Open(tbl_gen.txtbox_display) str_file_name = define_new_file_name DestWb.SaveAs str_file_name, FileFormat:=52 Set DestWb = Workbooks.Open(str_file_name) If WorkbookHasVBACode(DestWb) Then MsgBox STR_CODE_IN_DESTINATION_ERROR, vbInformation, "Generator" Exit Sub End If Call CopyModule(ThisWorkbook, "mod_public", DestWb) Call CopyModule(ThisWorkbook, "mod_main", DestWb) Call CopyModule(ThisWorkbook, "cls_calendar", DestWb) Application.Run "'" & DestWb.Name & "'!AddAButton" MsgBox "Datei " & str_file_name & " generiert.", vbInformation, "Generator" DestWb.Save DestWb.Close Set DestWb = Nothing Call OnEnd On Error GoTo 0 Exit Sub MainGen_Error: Select Case Err.Number Case 1004: MsgBox STR_UNCLOSED_FILE_ERROR Case Else: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure MainGen of Module mod_gen_main" End Select Call OnEnd End Sub Private Function WorkbookHasVBACode(wb As Workbook) Dim ModuleLineCount As Long On Error GoTo WorkbookHasVBACode_Error WorkbookHasVBACode = False ModuleLineCount = wb.VBProject.VBComponents(wb.CodeName).CodeModule.CountOfLines If ModuleLineCount > 25 Then WorkbookHasVBACode = True End If On Error GoTo 0 Exit Function WorkbookHasVBACode_Error: Debug.Print "error in WorkbookHasVBACode" End Function Public Function define_new_file_name() As String If tbl_gen.txtbox_name.Enabled And Len(tbl_gen.txtbox_name.Text) > 1 Then define_new_file_name = tbl_gen.txtbox_name.Text Else define_new_file_name = "_" & CLng(Now()) - 42390 & CStr(CDate(Now())) define_new_file_name = Replace(define_new_file_name, ":", "") define_new_file_name = Replace(define_new_file_name, ".", "") End If End Function Sub CopyModule(SourceWB As Workbook, strModuleName As String, TargetWB As Workbook) ' copies a module from one workbook to another ' example: ' CopyModule Workbooks("Book1.xls"), "Module1", Workbooks("Book2.xls") Dim strFolder As String Dim strTempFile As String strFolder = SourceWB.Path If Len(strFolder) = 0 Then strFolder = CurDir strFolder = strFolder & "\" strTempFile = strFolder & "~tmpexport.bas" On Error Resume Next SourceWB.VBProject.VBComponents(strModuleName).Export strTempFile TargetWB.VBProject.VBComponents.Import strTempFile Kill strTempFile On Error GoTo 0 End Sub Public Sub OnStart() Application.DisplayAlerts = False Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False End Sub Public Sub OnEnd() 'Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False End Sub Public Sub aaa() Dim i As Long If Environ("Username") = "v.doynov" Then Debug.Print "here you go ..." For i = ActiveWorkbook.Worksheets.Count To 1 Step -1 ActiveWorkbook.Worksheets(i).Unprotect Password:=s_CONST Next End If End Sub Public Function RGB2HTMLColor(B As Byte, G As Byte, R As Byte) As String Dim HexR As Variant, HexB As Variant, HexG As Variant Dim sTemp As String On Error GoTo ErrorHandler 'R HexR = Hex(R) If Len(HexR) < 2 Then HexR = "0" & HexR 'Get Green Hex HexG = Hex(G) If Len(HexG) < 2 Then HexG = "0" & HexG HexB = Hex(B) If Len(HexB) < 2 Then HexB = "0" & HexB RGB2HTMLColor = HexR & HexG & HexB Debug.Print "Leave H800 on its place" Exit Function ErrorHandler: Debug.Print "N O T successful" End Function ================================================ FILE: VBE/MovingModules.vb/mod_gen_public.vb ================================================ Option Explicit 'Microsoft Visual Basic For Applications Extensibility Library Public DestWb As Workbook ================================================ FILE: VBE/MovingModules.vb/mod_main.vb ================================================ Option Explicit Public Sub main() On Error GoTo main_Error Call OnStart Call ClearWritingPlace Call WriteMonthsAbove Call GenerateValuesInside Call GenerateSumsAtTheEnd Call BorderMe(ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(L_ROW_WITH_DATES, L_FIRST_COLUMN_TO_WRITE), ThisWorkbook.Sheets(1).Cells(obj_cal.LastRow, obj_cal.RightestColumn))) Call AutoFitAndMessageBox Call SetObjectsToNothing Call OnEnd On Error GoTo 0 Exit Sub main_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure main of Module mod_main" Call SetObjectsToNothing Call OnEnd End Sub Public Sub SetObjectsToNothing() Set r_range_4_dates = Nothing Set obj_cal = Nothing End Sub Public Sub AutoFitAndMessageBox() Range(ThisWorkbook.Sheets(1).Cells(L_ROW_WITH_DATES, L_FIRST_COLUMN_TO_WRITE), ThisWorkbook.Sheets(1).Cells(obj_cal.LastRow + 2, obj_cal.RightestColumn)).Columns.AutoFit MsgBox STR_FERTIG, vbInformation, STR_SCHADENSERSATZ End Sub Public Sub GenerateValuesInside() Dim l_counter_row As Long Dim l_counter_col As Long For l_counter_row = L_STARTING_ROW To obj_cal.LastRow For l_counter_col = L_FIRST_COLUMN_TO_WRITE To obj_cal.RightestColumn Call GenerateFormula(l_counter_row, l_counter_col) Next l_counter_col Next l_counter_row End Sub Public Sub WriteMonthsAbove() For l_counter = 0 To obj_cal.CalendarLength - 1 Set my_cell = ThisWorkbook.Sheets(1).Cells(L_STARTING_ROW - 1, L_FIRST_COLUMN_TO_WRITE + l_counter) my_cell = add_months(obj_cal.FirstMonth, l_counter) Call FormatMyCell(my_cell, False, True, True, True) Next l_counter End Sub Public Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row End Function Public Function add_months(my_date As Date, l_month As Long) As Date add_months = get_last_day_of_month(DateAdd("m", l_month, my_date)) End Function Public Function get_last_day_of_month(ByVal my_date As Date) As Date get_last_day_of_month = DateSerial(Year(my_date), Month(my_date) + 1, 0) End Function Public Sub ClearWritingPlace() Set obj_cal = New cls_calendar obj_cal.LastRow = last_row_with_data(1, ThisWorkbook.Sheets(1)) Set r_range_4_dates = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(L_RATE6_VERTRAG_COL, L_STARTING_ROW), ThisWorkbook.Sheets(1).Cells(obj_cal.LastRow, L_RATE5PR_TERMIN_COL)) ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(1, L_FIRST_COLUMN_TO_WRITE - 1), ThisWorkbook.Sheets(1).Cells(Rows.Count, Columns.Count)).Clear obj_cal.FirstMonth = Application.WorksheetFunction.Min(r_range_4_dates) obj_cal.LastMonth = Application.WorksheetFunction.Max(r_range_4_dates) obj_cal.CalendarLength = DateDiff("m", obj_cal.FirstMonth, obj_cal.LastMonth) obj_cal.RightestColumn = L_FIRST_COLUMN_TO_WRITE + obj_cal.CalendarLength - 1 End Sub Public Sub GenerateFormula(l_row, l_col) Dim date_date_above As Date Dim my_cell As Range Dim l_count_garages As Long Dim b_has_garage As Boolean: b_has_garage = False If WorksheetFunction.CountA(Cells(l_row, L_RATE6_VERTRAG_COL)) = 0 Then Exit Sub dbl_eur_m2 = ThisWorkbook.Sheets(1).Cells(2, 18) dbl_eur_garage = ThisWorkbook.Sheets(1).Cells(2, 19) date_date_above = ThisWorkbook.Sheets(1).Cells(L_ROW_WITH_DATES, l_col) Set my_cell = Cells(l_row, l_col) If Cells(l_row, L_RATE6_VERTRAG_COL) < get_last_day_of_month(Cells(l_row, L_RATE6_TERMIN_COL)) Then If date_date_above > Cells(l_row, L_RATE6_VERTRAG_COL) And date_date_above <= get_last_day_of_month(Cells(l_row, L_RATE6_TERMIN_COL)) Then my_cell = dbl_eur_m2 * Cells(l_row, 15) End If End If On Error Resume Next 'do not do this at home... If CLng(Cells(l_row, 3)) > 0 Then b_has_garage = True On Error GoTo 0 If Cells(l_row, L_RATE5PR_VERTRAG_COL) < Cells(l_row, L_RATE5PR_TERMIN_COL) And _ b_has_garage Then If date_date_above > get_last_day_of_month(Cells(l_row, L_RATE5PR_VERTRAG_COL)) And _ date_date_above <= get_last_day_of_month(Cells(l_row, L_RATE5PR_TERMIN_COL)) Then l_count_garages = find_in_string_times(Cells(my_cell.Row, 3)) + 1 my_cell = my_cell + l_count_garages * dbl_eur_garage End If End If If my_cell > 0 Then Call FormatMyCell(my_cell, True, False, False, True) End Sub Public Function find_in_string_times(my_cell As Range, Optional ch_char As String = "+") As Long find_in_string_times = UBound(Split(my_cell, ch_char)) End Function Public Sub FormatMyCell(ByRef my_cell As Range, Optional b_as_currency As Boolean = False, _ Optional b_as_date As Boolean = False, _ Optional b_as_dark As Boolean = False, _ Optional b_as_din As Boolean = False) If b_as_currency Then my_cell.NumberFormat = "#,##0.00 $" End If If b_as_date Then my_cell.NumberFormat = "[$-407]mmm/ yy;@" End If If b_as_dark Then my_cell.Interior.ThemeColor = xlThemeColorDark1 my_cell.Interior.TintAndShade = -0.249946592608417 End If If b_as_din Then my_cell.Font.Name = "DIN-Light" End If End Sub Public Sub OnStart() Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False End Sub Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False End Sub Public Sub GenerateSumsAtTheEnd() Dim l_counter As Long Dim my_cell As Range obj_cal.LastRow = obj_cal.LastRow + 1 For l_counter = 0 To obj_cal.CalendarLength - 1 Set my_cell = ThisWorkbook.Sheets(1).Cells(obj_cal.LastRow, L_FIRST_COLUMN_TO_WRITE + l_counter) my_cell.FormulaR1C1 = "=SUM(R6C:R" & obj_cal.LastRow - 1 & "C)" Call FormatMyCell(my_cell, True, False, True, True) Next l_counter Set my_cell = Cells(obj_cal.LastRow + 1, L_FIRST_COLUMN_TO_WRITE) my_cell.FormulaR1C1 = "=SUM(R[-1]C:R[-1]C" & L_FIRST_COLUMN_TO_WRITE + obj_cal.CalendarLength - 1 & ")" Call FormatMyCell(my_cell, True, False, True, True) End Sub Public Sub BorderMe(my_range) Dim l_counter As Long For l_counter = 7 To 10 '7 to 10 are the magic numbers for xlEdgeLeft etc With my_range.Borders(l_counter) .LineStyle = xlContinuous .Weight = xlMedium End With Next l_counter End Sub Public Sub AddAButton() Dim my_btn As Button Dim my_range As Range Set my_range = Sheets(1).Cells(1, 19) Set my_btn = Sheets(1).Buttons.Add(my_range.Left, my_range.Top, my_range.Width, my_range.Height) my_btn.OnAction = "main" my_btn.Caption = "Laufen" my_btn.Name = "created_by_macro" End Sub ================================================ FILE: VBE/MovingModules.vb/mod_public.vb ================================================ Option Explicit Public Const L_STARTING_ROW = 6 Public Const L_RATE6_VERTRAG_COL = 6 Public Const L_RATE6_TERMIN_COL = 10 Public Const L_RATE5PR_VERTRAG_COL = 8 Public Const L_RATE5PR_TERMIN_COL = 12 Public Const STR_FERTIG = "Fertig!" Public Const STR_SCHADENSERSATZ = "Schadensersatz" Public Const L_FIRST_COLUMN_TO_WRITE = 21 Public Const L_ROW_WITH_DATES = 5 Public Const L_WOHNFLAECHE_COL = 15 Public obj_cal As cls_calendar Public dbl_eur_m2 As Double Public dbl_eur_garage As Double Public l_counter As Long Public r_range_4_dates As Range Public my_cell As Range ================================================ FILE: VBE/Preprocessor.vb ================================================ Option Explicit #If Win32 Then Sub MyTest() Debug.Print "32 bits." End Sub #ElseIf Win64 Then Sub MyTest() Debug.Print "64 bits." 'This should be an error only if it is 64 bits: Debug.Print 0 / 0 End Sub #ElseIf Win16 Sub MyTest() Debug.Print "16 bits." End Sub #End If Sub MyExecutiveMain() MyTest End Sub Sub WhichVersion() #If VBA7 Then Debug.Print "VBA7" #Else Debug.Print "NOT VBA7" #End If End Sub #If VBA7 And Win64 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If ================================================ FILE: VBE/PrintAllProcedures.vb ================================================ '--------------------------------------------------------------------------------------- ' Purpose : Prints all subs and functions in a project ' Prerequisites: Microsoft Visual Basic for Applications Extensibility 5.3 library ' CreateLogFile ' How to run: Run GetFunctionAndSubNames, set a parameter to blnWithParentInfo ' If ComponentTypeToString(vbext_ct_StdModule) = "Code Module" Then ' ' Used: ComponentTypeToString from -> http://www.cpearson.com/excel/vbe.aspx '--------------------------------------------------------------------------------------- Option Explicit Private strSubsInfo As String Public Sub GetFunctionAndSubNames() Dim item As Variant strSubsInfo = "" For Each item In ThisWorkbook.VBProject.VBComponents If ComponentTypeToString(vbext_ct_StdModule) = "Code Module" Then ListProcedures item.name, False 'Debug.Print item.CodeModule.lines(1, item.CodeModule.CountOfLines) End If Next item CreateLogFile strSubsInfo End Sub Private Sub ListProcedures(strName As String, Optional blnWithParentInfo = False) 'Microsoft Visual Basic for Applications Extensibility 5.3 library Dim VBProj As VBIDE.VBProject Dim VBComp As VBIDE.VBComponent Dim CodeMod As VBIDE.CodeModule Dim LineNum As Long Dim ProcName As String Dim ProcKind As VBIDE.vbext_ProcKind Set VBProj = ActiveWorkbook.VBProject Set VBComp = VBProj.VBComponents(strName) Set CodeMod = VBComp.CodeModule With CodeMod LineNum = .CountOfDeclarationLines + 1 Do Until LineNum >= .CountOfLines ProcName = .ProcOfLine(LineNum, ProcKind) If blnWithParentInfo Then strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & strName & "." & ProcName Else strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & ProcName End If LineNum = .ProcStartLine(ProcName, ProcKind) + .ProcCountLines(ProcName, ProcKind) + 1 Loop End With End Sub Function ComponentTypeToString(ComponentType As VBIDE.vbext_ComponentType) As String Select Case ComponentType Case vbext_ct_ActiveXDesigner ComponentTypeToString = "ActiveX Designer" Case vbext_ct_ClassModule ComponentTypeToString = "Class Module" Case vbext_ct_Document ComponentTypeToString = "Document Module" Case vbext_ct_MSForm ComponentTypeToString = "UserForm" Case vbext_ct_StdModule ComponentTypeToString = "Code Module" Case Else ComponentTypeToString = "Unknown Type: " & CStr(ComponentType) End Select End Function ================================================ FILE: VBE/SaveThis.vb ================================================ Public Sub SaveThis() 'saves foo.4.5.6.xlsb to foo.4.5.7.xlsb Dim mySplitter As Variant mySplitter = Split(ThisWorkbook.FullName, ".") Dim oldVersion As String oldVersion = mySplitter(UBound(mySplitter) - 1) Dim newVersion As String newVersion = oldVersion + 1 mySplitter(UBound(mySplitter) - 1) = newVersion Dim newName As String newName = Join(mySplitter, ".") ThisWorkbook.SaveAs newName Debug.Print "Saved as:" & vbCrLf & newName End Sub Public Sub SaveThisM() 'saves foo.4.5.6.xlsb to foo.4.5.7.xlsb 'and moves the old one to root\Arch\Auto Dim oldName As String oldName = ThisWorkbook.Name SaveThis Dim fso As New FileSystemObject fso.MoveFile Source:=ThisWorkbook.path & "\" & oldName, Destination:=ThisWorkbook.path & "\Arch\Auto\" & oldName Debug.Print "Moved to:" & vbCrLf & ThisWorkbook.path & "\Arch\Auto\" & oldName End Sub ================================================ FILE: XML/XmlSimpleManualParser.txt ================================================ Option Explicit Sub TestMe() Dim xmlObj As Object Set xmlObj = CreateObject("MSXML2.DOMDocument") xmlObj.async = False xmlObj.validateOnParse = False xmlObj.Load ("C:\Desktop\test.xml") Dim nodesThatMatter As Object Dim node As Object Set nodesThatMatter = xmlObj.SelectNodes("//gfi_message/body/data/node") For Each node In nodesThatMatter Dim child As Variant For Each child In node.ChildNodes Dim childOfChild As Object Dim childOfChildInfo As String For Each childOfChild In child.Attributes childOfChildInfo = childOfChildInfo & " -> " & childOfChild.Text Next childOfChild Debug.Print Right(childOfChildInfo, Len(childOfChildInfo) - 4) childOfChildInfo = vbNullString Next child Next node End Sub ================================================ FILE: XML/readme.md ================================================ # VBA - XML VitoshAcademy articles for XML: - [xml with php make links easily](https://www.vitoshacademy.com/xml-with-php-make-links-easily/) - [xml with css presentation of a simple web page](https://www.vitoshacademy.com/xml-with-css-presentation-of-a-simple-web-page/) - [php get-data from xml to html file with php](https://www.vitoshacademy.com/php-get-data-from-xml-to-html-file-with-php/) - [sql make xml from a sql database](https://www.vitoshacademy.com/sql-make-xml-from-a-sql-database/) - [vb xml generator with visual basic](https://www.vitoshacademy.com/vb-xml-generator-with-visual-basic/) This one looks ok: - https://github.com/VBA-tools/VBA-XML :cactus: :four_leaf_clover: :poodle: :flags: ================================================ FILE: XML/test.xml ================================================
123 2018-02-08T15:59:41+08:00 0.15
================================================ FILE: __Arch/00.vb ================================================ Public Function change_commas(ByVal myValue As Variant) As String Dim str_temp As String str_temp = CStr(myValue) change_commas = Replace(str_temp, ",", ".") End Function Public Function bubble_sort(ByRef TempArray As Variant) As Variant Dim Temp As Variant Dim i As Long Dim NoExchanges As Long ' Loop until no more "exchanges" are made. Do NoExchanges = True ' Loop through each element in the array. For i = LBound(TempArray) To UBound(TempArray) - 1 ' If the element is greater than the element ' following it, exchange the two elements. If CLng(TempArray(i)) > CLng(TempArray(i + 1)) Then NoExchanges = False Temp = TempArray(i) TempArray(i) = TempArray(i + 1) TempArray(i + 1) = Temp End If Next i Loop While Not (NoExchanges) bubble_sort = TempArray On Error GoTo 0 Exit Function End Function Public Function get_last_day_of_month(ByVal my_date As Date) As Date get_last_day_of_month = DateSerial(Year(my_date), Month(my_date) + 1, 0) End Function Public Function get_first_day_of_month(ByVal my_date As Date) As Date get_first_day_of_month = DateSerial(Year(my_date), Month(my_date), 1) End Function Public Function add_months(ByVal my_date As Date, ByVal i_month As Long) As Date add_months = get_last_day_of_month(DateAdd("m", i_month, my_date)) End Function Public Function add_months_and_get_first_date(ByVal my_date As Date, ByVal i_month As Long) As Date add_months_and_get_first_date = get_first_day_of_month(DateAdd("m", i_month, my_date)) End Function Public Function calculate_years_from_months(total_term) As Long calculate_years_from_months = total_term \ MONTHS_IN_YEAR If total_term Mod MONTHS_IN_YEAR Then calculate_years_from_months = calculate_years_from_months + 1 End Function Public Function IsArrayAllocated(Arr As Variant) As Boolean On Error Resume Next IsArrayAllocated = IsArray(Arr) And Not IsError(LBound(Arr, 1)) And LBound(Arr, 1) <= UBound(Arr, 1) On Error GoTo 0 End Function Public Sub print_array(ByRef my_array As Variant) Dim counter As Long For counter = LBound(my_array) To UBound(my_array) Debug.Print counter & " --> " & my_array(counter) Next counter End Sub Public Sub GenerateSumsOutput(l_lower_row As Long, l_higher_row As Long, l_current_row As Long) Dim r_cell As Range Dim l_counter As Long For l_counter = arr_calendar_settings(2) To arr_calendar_settings(3) Set r_cell = tbl_output.Cells(l_current_row, l_counter) r_cell.FormulaR1C1 = "=SUM(R" & l_higher_row & "C:R" & l_lower_row & "C)" Next l_counter Set r_cell = Nothing End Sub Public Function bool_zero_or_empty(ByRef cell As Range, Optional b_is_range = False) As Boolean If b_is_range Then For Each current_cell In cell If (IsEmpty(current_cell) Or current_cell.Value = 0) Then bool_zero_or_empty = True Exit Function Else bool_zero_or_empty = False End If Next current_cell Else If (IsEmpty(cell) Or cell.Value = 0) Then bool_zero_or_empty = True Else bool_zero_or_empty = False End If End If End Function Public Sub FormatAsDate(ByRef cell As Range) cell.NumberFormat = "[$-407]mmm/ yy;@" End Sub Public Sub FormatAsPercent(ByRef my_cell As Range, Optional l_numbers = 2) If l_numbers = 3 Then my_cell.NumberFormat = "0.000%" Else my_cell.NumberFormat = "0.00%" End If End Sub Public Sub FormatAsCurrency(ByRef cell As Range, Optional ByVal b_change_0 = False, Optional b_make_gray = True, Optional b_make_round = True) Dim b_is_alone As Boolean b_is_alone = IIf(cell.Rows.Count + cell.Columns.Count <> 2, False, True) If IsNumeric(cell.Value) And (Not cell.HasFormula) Then cell.Value = Round(cell.Value, 2) End If If b_make_round Then cell.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" Else cell.NumberFormat = "$#,##0.00_);($#,##0.00)" End If If b_change_0 Then With cell .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=0" .FormatConditions(1).Font.ThemeColor = xlThemeColorDark1 .FormatConditions(1).Font.TintAndShade = -0.4 End With End If If b_is_alone Then If b_make_gray And cell.Value = 0 Then With cell .Cells.Font.Color = RGB(191, 191, 191) End With End If End If End Sub Public Sub FormatAs_Eur_pro_m2(my_cell As Range) my_cell.NumberFormat = "#,##0.00 "" € / m²""" End Sub Public Sub FormatRedAndBold(ByRef my_cell As Range, Optional isBold = True) my_cell.Font.Color = -16777063 my_cell.Font.TintAndShade = 0 If isBold Then my_cell.Font.Bold = True End Sub Public Function millions_eur(ByVal my_value As Long) As Long millions_eur = my_value / 1000000 End Function Public Sub WhiteYourself(ByVal lines As Long, ByRef my_sheet As Worksheet) Dim str_lines As String str_lines = lines & ":" & lines With my_sheet.Rows(str_lines).Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End Sub Public Sub WhiteCell(ByRef my_cell As Range) my_cell.Font.ThemeColor = xlThemeColorDark1 my_cell.Font.TintAndShade = 0 End Sub Public Sub FormatFontColorToGrey(ByRef cell As Range) cell.Font.Color = RGB(128, 128, 128) End Sub Public Function sum_range(my_range As Range) As Double Dim cell As Range sum_range = 0 For Each cell In my_range sum_range = sum_range + cell. Next End Function Public Function make_random(down As Long, up As Long) As Long make_random = CLng((up - down + 1) * Rnd + down) If make_random > up Then make_random = up If make_random < down Then make_random = down End Function Public Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).row End Function Sub CopyValues(rngSource As Range, rngTarget As Range) rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value End Sub Public Function check_if_hidden(r_range As Range) As Boolean If r_range.EntireRow.Hidden Or r_range.EntireColumn.Hidden Then check_if_hidden = True End If End Function Function last_row(Optional str_sheet As String, Optional column_to_check As Long = 1) As Long Dim shSheet As Worksheet If str_sheet = vbNullString Then Set shSheet = ActiveSheet Else Set shSheet = Worksheets(str_sheet) End If last_row = shSheet.Cells(shSheet.Rows.Count, column_to_check).End(xlUp).row End Function Function last_column(Optional str_sheet As String, Optional row_to_check As Long = 1) As Long Dim shSheet As Worksheet If str_sheet = vbNullString Then Set shSheet = ActiveSheet Else Set shSheet = Worksheets(str_sheet) End If last_column = shSheet.Cells(row_to_check, shSheet.Columns.Count).End(xlToLeft).Column End Function Public Function letter_col(ByVal col As Long) As String letter_col = Split(Cells(1, col).Address, "$")(1) End Function Public Function b_value_in_array(my_value As Variant, my_array As Variant, Optional b_is_string As Boolean = False) As Boolean Dim l_counter If b_is_string Then my_array = Split(my_array, ":") End If For l_counter = LBound(my_array) To UBound(my_array) my_array(l_counter) = CStr(my_array(l_counter)) Next l_counter b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0)) End Function Public Sub DrawBordersAroundRange(b_remove As Boolean) If b_remove Then [set_format].Copy [input_all_ba].PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False 'make the last month white for austria If tbl_Input.opt_os Then For Each current_cell In [input_construction_time] tbl_Input.Cells(current_cell.row + 8, 12).Font.Color = vbWhite Next current_cell End If Else [set_format_without_borders].Copy [input_all_ba].PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = xlNone End If End Sub Public Sub UnhideAll() Dim Sheet As Worksheet For Each Sheet In ThisWorkbook.Worksheets ' If Sheet.Visible = Not xlSheetVisible Then Sheet.Visible = xlSheetVisible Sheet.Visible = xlSheetVisible Next Sheet Call UnprotectAll End Sub Public Sub UnprotectAll() Dim i As Long For i = ActiveWorkbook.Worksheets.Count To 1 Step -1 ActiveWorkbook.Worksheets(i).Unprotect Password:=s_CONST Next End Sub Public Sub HideNeeded() Dim var_Sheet As Variant Dim arr_visible_sheets As Variant Dim arr_hidden_sheets As Variant Call OnStart arr_visible_sheets = Array(tbl_Input) arr_hidden_sheets = Array(tbl_output, tbl_calendar, tbl_log, tbl_settings, tbl_results, tbl_settings_bau) For Each var_Sheet In arr_visible_sheets var_Sheet.Visible = xlSheetVisible Next var_Sheet For Each var_Sheet In arr_hidden_sheets var_Sheet.Visible = xlSheetVeryHidden Next var_Sheet Call OnEnd End Sub Public Sub add_comment_to_selection(my_comment As Range) Dim b As Boolean b = True For Each current_cell In Selection If b Then current_cell.ClearComments current_cell.AddComment my_comment.Text current_cell.Comment.Visible = False current_cell.Comment.Shape.ScaleWidth 4, msoFalse, msoScaleFromTopLeft current_cell.Comment.Shape.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft End If b = Not b Next current_cell End Sub Public Sub delete_comment_in_selection() For Each current_cell In Selection current_cell.ClearComments Next current_cell End Sub Sub DeleteDrawingObjects() Dim l_counter As Long For l_counter = tbl_Input.DrawingObjects().Count To 1 Step -1 'Debug.Print tbl_Input.DrawingObjects(l_counter).name If Left(tbl_Input.DrawingObjects(l_counter).Name, 7) = "TextBox" Then tbl_Input.DrawingObjects(l_counter).Delete End If Next l_counter End Sub Sub CoverRange(ByRef R As Range) Dim L As Long, t As Long, W As Long, H As Long L = R.Left t = R.Top W = R.Width H = R.Height 'msoTextOrientationHorizontal With ActiveSheet.Shapes .AddTextbox(msoTextOrientationVertical, L, t, W, H).Select Selection.ShapeRange.Line.Visible = msoFalse End With End Sub Public Sub PrintPDF() On Error GoTo PrintPDF_Error ActiveSheet.PageSetup.Zoom = False ActiveSheet.PageSetup.BlackAndWhite = Not tbl_Input.cb_print_color [input_print_area].ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=CStr([input_object_address] & "_" & [input_calculation_date]), _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=True On Error GoTo 0 Exit Sub PrintPDF_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PrintPDF of Modul mod_Drucken" End Sub Public Sub PrintPage() Dim Sh As Worksheet Dim rngPrint As Range Dim s_reduce_paper_title As String On Error GoTo PrintPage_Error s_reduce_paper_title = "Reduzieren Sie den Papierverbrauch" ActiveSheet.PageSetup.BlackAndWhite = Not tbl_Input.cb_print_color Set Sh = ActiveSheet Set rngPrint = [input_print_area] With Sh.PageSetup .Orientation = xlPortrait .Zoom = False .FitToPagesTall = 1 .FitToPagesWide = 1 End With Select Case MsgBox("Sind Sie sicher, dass Sie drucken moechten?", vbYesNo Or vbQuestion Or vbDefaultButton1, s_reduce_paper_title) Case vbYes Select Case MsgBox("Wirklich sicher, dass Sie drucken moechten?", vbYesNo Or vbQuestion Or vbDefaultButton1, s_reduce_paper_title) Case vbYes rngPrint.PrintOut End Select End Select On Error GoTo 0 Exit Sub PrintPage_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PrintPage of Modul mod_Drucken" End Sub Public Sub ChangeCaption(lng_message As Long) Select Case lng_message Case 0: Application.Caption = "Currently running" Case 1: Application.Caption = "Nicht erfolgreich" Case 2: Application.Caption = "Erfolg" Case Else: Application.Caption = "Unknown" End Select End Sub Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False Application.Calculation = xlAutomatic Call ProtectPAKU2 End Sub Public Sub OnStart() Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlAutomatic ActiveWindow.View = xlNormalView Call UnProtectPAKU2 End Sub Public Sub DeleteName(sName As String) On Error GoTo DeleteName_Error ActiveWorkbook.Names(sName).Delete Debug.Print sName & " is deleted!" On Error GoTo 0 Exit Sub DeleteName_Error: Debug.Print sName & " not present or some error" On Error GoTo 0 End Sub Public Function RGB2HTMLColor(R As Byte, G As Byte, _ b As Byte) As String 'INPUT: Numeric (Base 10) Values for R, G, and B) 'RETURNS: 'A string that can be used as an HTML Color '(i.e., "#" + the Hexadecimal equivalent) 'For VBA the RGB is reversed. R and B are revered... Dim HexR, HexB, HexG As Variant On Error GoTo ErrorHandler 'R HexR = Hex(R) If Len(HexR) < 2 Then HexR = "0" & HexR 'Get Green Hex HexG = Hex(G) If Len(HexG) < 2 Then HexG = "0" & HexG HexB = Hex(b) If Len(HexB) < 2 Then HexB = "0" & HexB RGB2HTMLColor = "#" & HexR & HexG & HexB ErrorHandler: End Function Public Sub SelectAndChange() Dim current_cells_range As Range Dim l_step_between_BA As Long Dim l_counter As Long Dim col As Long Dim row As Long l_step_between_BA = 22 col = Selection.Column row = Selection.row 'Beware what you select, for it would stay selected! :) Set current_cells_range = Selection For l_counter = 0 To 9 Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + l_step_between_BA * l_counter, col)) Next l_counter current_cells_range.Select End Sub Function NamedRangeExists(strRangeName As String) As Boolean Dim my_range As Range On Error Resume Next Set my_range = Range(strRangeName) If Not my_range Is Nothing Then NamedRangeExists = True On Error GoTo 0 End Function Function getRGB2(l_long) As String Dim R As Long Dim G As Long Dim B As Long R = l_long Mod 256 G = l_long \ 256 Mod 256 B = l_long \ 65536 Mod 256 getRGB2 = "R=" & R & ", G=" & G & ", B=" & B End Function Public Function b_value_in_array(my_value As Variant, _ my_array As Variant, _ Optional b_is_string As Boolean = False, _ Optional str_separator As String = ":") As Boolean Dim l_counter If b_is_string Then my_array = Split(my_array, str_separator) End If For l_counter = LBound(my_array) To UBound(my_array) my_array(l_counter) = CStr(my_array(l_counter)) Next l_counter b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0)) End Function Public Function valueInArray(myValue As Variant, _ myArray As Variant, Optional isString As Boolean = False) As Boolean Dim counter As Long If isString Then myArray = Split(myArray, ":") End If For counter = LBound(myArray) To UBound(myArray) myArray(counter) = CStr(myArray(counter)) Next counter valueInArray = Not IsError(Application.Match(CStr(myValue), myArray, 0)) End Function 'call lockscroll(Array(tbl_main.Name,"A1:W100")) Public Sub LockScroll(ByRef my_array As Variant) Dim l_counter As Long If Not Len(Join(my_array)) > 0 Then Exit Sub For l_counter = 0 To UBound(my_array) Step 2 ThisWorkbook.Sheets(my_array(l_counter)).ScrollArea = my_array(l_counter + 1) Next l_counter End Sub Public Function col_value_find_value(s_wanted As String, tbl As Object) As Long On Error GoTo col_value_find_value_Error col_value_find_value = tbl.Cells(1, 1).EntireRow.Find(What:=s_wanted).Column On Error GoTo 0 Exit Function col_value_find_value_Error: Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure col_value_find_value of Function mod_various" col_value_find_value = -1 End Function Public Function row_value_find_value(s_wanted As String, tbl As Object) As Long On Error GoTo row_value_find_value_Error row_value_find_value = tbl.Cells(1, 1).EntireColumn.Find(What:=s_wanted).Row On Error GoTo 0 Exit Function row_value_find_value_Error: Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure row_value_find_value of Function mod_various" row_value_find_value = -1 End Function Public Sub CreateChart() Dim myChtObj As ChartObject Dim rngChtData As Range Dim rngChtXVal As Range Dim iColumn As Long Dim l_border As Long: l_border = Application.Width * 0.02 Set rngChtData = tbl_input.Range(tbl_input.Cells(1, CALENDAR_START_COL), tbl_input.Cells(2, CALENDAR_START_COL).End(xlToRight)) Debug.Print Application.Width Debug.Print Application.Width - l_border Set myChtObj = tbl_input.ChartObjects.Add( _ Left:=Application.Width / 4, _ Width:=2 * (Application.Width / 3), _ Top:=tbl_input.Cells(7, 4).Top, _ Height:=Application.Width / 5) myChtObj.Chart.SetSourceData Source:=rngChtData myChtObj.Chart.Legend.Delete myChtObj.Chart.ChartStyle = 40 myChtObj.Chart.ClearToMatchStyle Cells(1, 1).Select Set rngChtData = Nothing Set myChtObj = Nothing On Error GoTo 0 Exit Sub End Sub Public Sub PrintMyName() Debug.Print Chr(194) & Chr(200) & Chr(210) & Chr(206) & Chr(216) End Sub Public Function Now() As Date If [set_in_production] Then Now = VBA.Now() Else Now = DateSerial(2017, 2, 2) + TimeSerial(15, 1, 2) End If End Function ================================================ FILE: __Arch/01.vb ================================================ Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then Cancel = True End Sub Private Sub Workbook_Open() On Error GoTo Workbook_Open_Error Call HideNeeded Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", false)" Application.DisplayFormulaBar = False [set_root_user] = False If Not b_value_in_array(Environ("username"), ADMINS, True) Then Application.OnKey "%{F11}", "" End If Application.OnKey "^c", "" Application.OnKey "^v", "" Application.OnKey "^x", "" Application.WindowState = xlMaximized On Error GoTo 0 Exit Sub Workbook_Open_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_Open of Sub xl_paku" Me.Save ThisWorkbook.Close End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error GoTo Workbook_BeforeClose_Error Cancel = False ThisWorkbook.Save Application.DisplayAlerts = False Call HideNeeded Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" Application.DisplayAlerts = True ActiveWindow.DisplayHeadings = True Application.DisplayFormulaBar = True ActiveSheet.PageSetup.BlackAndWhite = False Me.Save 'Return the disabled keys: Application.OnKey "%{F11}" Application.OnKey "^c" Application.OnKey "^v" Application.OnKey "^x" On Error GoTo 0 Exit Sub Workbook_BeforeClose_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_BeforeClose of Sub xl_paku" End Sub Private Sub Workbook_NewSheet(ByVal Sh As Object) paku_message_title = tbl_settings.Range("AJ8") If Not tbl_settings.Visible Then With Application Application.ScreenUpdating = False Application.DisplayAlerts = False Sh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End With MsgBox (Environ("UserName") & ", Sie können Blätter nicht hinzufügen."), vbInformation, paku_message_title End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveWindow.Zoom > 100 Or ActiveWindow.Zoom < 70 Then ActiveWindow.Zoom = 100 End If End Sub ================================================ FILE: __Arch/03.vb ================================================ Public Sub ShowErrors() Dim my_cell As Range Dim str_result As String For Each my_cell In ActiveSheet.UsedRange If IsError(my_cell) Then str_result = str_result & vbCrLf & my_cell.Address End If Next my_cell If Len(str_result) > 1 Then MsgBox str_result End Sub Public Function fnStrChangeCommas(ByVal myValue As Variant) As String fnStrChangeCommas = Replace(CStr(myValue), ",", ".") End Function 'Public Function change_commas(ByVal myValue As Variant) As String ' ' Dim str_temp As String ' ' str_temp = CStr(myValue) ' change_commas = Replace(str_temp, ",", ".") ' 'End Function Public Sub EnableMySaves() Application.OnKey "%{F11}" Application.OnKey "^c" Application.OnKey "^v" Application.OnKey "^x" If Not b_value_in_array(Environ("username"), ADMINS, True) Then Application.EnableCancelKey = xlDisabled End Sub Public Sub DisableMySaves() Application.OnKey "^c", "DisabledCombination" Application.OnKey "^v", "DisabledCombination" Application.OnKey "^x", "DisabledCombination" Application.EnableCancelKey = xlInterrupt End Sub ================================================ FILE: __Arch/04 - Excel Objects Edition.vb ================================================ Option Explicit Sub RemoveFormulasFromAnotherSheet() Dim rng_cell As Range Dim str_inside As String: str_inside = ":\" For Each rng_cell In ActiveSheet.UsedRange 'Selection If InStr(rng_cell.Formula, str_inside) > 0 Then Debug.Print rng_cell.Formula Debug.Print rng_cell.Address Debug.Print "---------------------------" 'rng_cell.Value = rng_cell.Value End If Next rng_cell End Sub Sub ExtendContentFromRight() Dim rng_first As Range Set rng_first = Selection.Cells(1, 1) Selection.Formula = rng_first.Formula Set rng_first = Nothing End Sub Public Sub ColorSS() On Error GoTo ColorSS_Error 'Colors Saturdays and Sundays. Dim r_cell As Range Dim r_range As Range For Each r_cell In Selection If Weekday(r_cell.Value) = 1 Or Weekday(r_cell.Value) = 7 Then Set r_range = ActiveSheet.Range(Cells(4, r_cell.Column), Cells(667, r_cell.Column)) r_range.Interior.Color = 13434828 End If Next r_cell Set r_range = Nothing On Error GoTo 0 Exit Sub ColorSS_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ColorSS of Sub mod_play_with_me" End Sub '--------------------------------------------------------------------------------------- ' Method : AddStringToFormula ' Author : v.doynov ' Date : 29.03.2016 ' Purpose: Call like this =>> call AddStringToFormula(")*set_teilung_ba1") or ba2 '--------------------------------------------------------------------------------------- Public Sub AddStringToFormula(s_added_str As String) Dim r_range As Range Dim l_counter As Long On Error GoTo AddStringToFormula_Error Debug.Print Selection.Address & " -> " & Selection.Parent.Name Stop 'Make sure you have only one sheet active in the current app For Each r_range In Selection.SpecialCells(xlCellTypeFormulas) r_range.Formula = "=(" & Right(r_range.Formula, Len(r_range.Formula) - 1) & s_added_str Debug.Print r_range.Address & " changed" l_counter = l_counter + 1 Next r_range Debug.Print vbCrLf & "Total Changes: " & l_counter On Error GoTo 0 Exit Sub AddStringToFormula_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddStringToFormula of Module mod_play" End Sub Sub DisplayCommentsInWS() Dim ws_target As Worksheet Dim ws_source As Worksheet Dim rng_rng As Range Dim rng_cell As Variant Dim i As Long: i = 2 Dim b_comment_found As Boolean Call OnStart Set ws_target = Sheets("Comments") 'I would love to have an error if it does not exist ws_target.Cells.Delete ws_target.Range("A1") = "Sheet" ws_target.Range("B1") = "Address" ws_target.Range("C1") = "Comment" ws_target.Range("D1") = "Cell value" ws_target.Range("E1") = "Author" On Error Resume Next For Each ws_source In ThisWorkbook.Worksheets Set rng_cell = ws_source.Cells.SpecialCells(xlCellTypeComments) If Not IsEmpty(rng_cell) Then For Each rng_rng In rng_cell b_comment_found = True ws_target.Range("A" & i) = ws_source.Name ws_target.Range("B" & i) = rng_rng.Address ws_target.Range("C" & i) = rng_rng.Comment.Text ws_target.Range("C" & i).WrapText = False ws_target.Range("D" & i) = rng_rng.Value ws_target.Range("E" & i) = rng_rng.Comment.Author i = i + 1 Debug.Print "Working " & i Next rng_rng End If Next ws_source If Not b_comment_found Then Debug.Print "No Comments were found. Tab ""Comments"" is deleted" Application.DisplayAlerts = False ws_target.Delete Application.DisplayAlerts = True Else Debug.Print "End" End If ws_target.Columns.AutoFit Call OnEnd On Error GoTo 0 Set rng_rng = Nothing Set ws_source = Nothing Set ws_target = Nothing Set rng_cell = Nothing End Sub Public Sub DeleteAllComments() Dim ws As Worksheet Dim cmt As Comment For Each ws In ThisWorkbook.Worksheets For Each cmt In ws.Comments Debug.Print "Comment deleted" cmt.Delete Next cmt Next ws End Sub Public Sub OnStart() Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False End Sub Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False End Sub ================================================ FILE: __Arch/AllFormats.vb ================================================ Call FormatDin(my_cell) Call FormatDark(my_cell) Public Sub FormatDark(ByRef my_cell As range) my_cell.Interior.ThemeColor = xlThemeColorDark1 my_cell.Interior.TintAndShade = -0.249946592608417 End Sub Public Sub FormatDin(ByRef my_cell As range) my_cell.Font.Name = "DIN-Light" End Sub ================================================ FILE: __Arch/AverageRowColumnNamedRange.vb ================================================ Public Function calculate_avg_row(rng As Range, Optional l_row As Long = 1) As Double Dim my_start As Range Dim my_end As Range Set my_start = Cells(rng.Cells(l_row, 1).Row, rng.Cells(l_row, 1).Column) Set my_end = rng.Cells(l_row, rng.Columns.Count) Debug.Print my_start.Address Debug.Print my_end.Address calculate_avg_row = WorksheetFunction.Average(Range(my_start, my_end)) End Function Option Explicit Public Function calculate_avg(rng As Range, Optional l_starting_col As Long = 1, Optional l_end_col As Long = 1) As Double Dim my_start As Range Dim my_end As Range Set my_start = Cells(rng.Cells(1, 1).Row, l_starting_col + rng.Cells(1, 1).Column - 1) Set my_end = Cells(rng.Cells(rng.Rows.Count, l_end_col).Row, rng.Columns.Count - rng.Cells(1, l_end_col).Column + l_end_col) 'Debug.Print my_start.Address 'Debug.Print my_end.Address calculate_avg = WorksheetFunction.Average(Range(my_start, my_end)) End Function ================================================ FILE: __Arch/BorderMeBorderRange.vb ================================================ Public Sub BorderMe(my_range) Dim l_counter As Long For l_counter = 7 To 10 '7 to 10 are the magic numbers for xlEdgeLeft etc With my_range.Borders(l_counter) .LineStyle = xlContinuous .Weight = xlMedium End With Next l_counter End Sub ================================================ FILE: __Arch/Classes/Class Builder VBA/cls_ba.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "cls_ba" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private p_row As Long Private p_vertriebsstart As Date Private p_counter_ba As Long Public Property Let Row(value As Long) p_row = value End Property Public Property Get Row() As Long Row = p_row End Property Public Property Let Vertriebsstart(value As Date) p_vertriebsstart = value End Property Public Property Get Vertriebsstart() As Date Vertriebsstart = p_vertriebsstart End Property Public Property Let CounterBA(value As Long) p_counter_ba = value End Property Public Property Get CounterBA() As Long CounterBA = p_counter_ba End Property ================================================ FILE: __Arch/Classes/Class Builder VBA/cls_project.cls ================================================ VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "cls_project" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private p_ba_info() As cls_ba Public Sub AddBA(ByVal obj_ba As cls_ba) ReDim Preserve p_ba_info(UBound(p_ba_info) + 1) Set p_ba_info(UBound(p_ba_info)) = obj_ba End Sub Private Sub Class_Initialize() ReDim p_ba_info(0) End Sub ================================================ FILE: __Arch/Classes/Class Builder VBA/mod_main.bas ================================================ Attribute VB_Name = "mod_main" Option Explicit Public obj_project As cls_project Public Sub SetObjectBA() Dim l_counter As Long Set obj_project = New cls_project For l_counter = 0 To 2 obj_project.AddBA Cls_BA_Builder(l_counter, l_counter + 5, Now()) Next l_counter End Sub Public Function Cls_BA_Builder(f_count_ba As Long, _ f_row As Long, _ f_vertriebsstart As Date) As cls_ba Dim obj As cls_ba Set obj = New cls_ba obj.CounterBA = f_count_ba obj.Row = f_row obj.Vertriebsstart = f_vertriebsstart Set Cls_BA_Builder = obj End Function ================================================ FILE: __Arch/Classes/class-project/Call By Names ================================================ Public Sub GetInformationPrinted() 'Tools - References - TypeLib Information Dim k As cls_arrCalendarSettings Dim mi As TLI.MemberInfo Dim i As Long Dim ti As TLI.TypeInfo Dim t As TLI.TLIApplication Set k = New cls_arrCalendarSettings k.TopRow = 10 k.BottomRow = 15 k.LeftCol = 3 k.RightCol = 10 k.SonstigesProBA = 1000.12 k.VerhaltnisBaukostenToPlanerkosten = 0.35 k.Vertriebsstart = Now() k.Vertriebsstart_Col = 50 'Now printing all Set t = New TLI.TLIApplication Set ti = t.InterfaceInfoFromObject(k) For Each mi In ti.Members Debug.Print mi.name Debug.Print CallByName(k, mi.name, VbGet) Next mi Set k = Nothing End Sub ================================================ FILE: __Arch/Classes/class-project/check_properties.vb ================================================ Public Sub GetInformationPrinted() 'Tools - References - TypeLib Information Dim k As cls_arrCalendarSettings Dim mi As TLI.MemberInfo Dim ti As TLI.TypeInfo Dim t As TLI.TLIApplication Dim b_show As Boolean Set k = New cls_arrCalendarSettings k.TopRow = 10 k.BottomRow = 15 k.LeftCol = 3 k.RightCol = 10 k.SonstigesProBA = 1000.12 k.VerhaltnisBaukostenToPlanerkosten = 0.35 k.Vertriebsstart = Now() k.Vertriebsstart_Col = 50 'Now printing all Set t = New TLI.TLIApplication Set ti = t.InterfaceInfoFromObject(k) For Each mi In ti.Members '0 is for GET Properties, '1 is for LET Properties 'Change accordingly If mi.ReturnType.PointerLevel = 0 Then Debug.Print mi.name & vbCrLf; CallByName(k, mi.name, VbGet) & vbCrLf End If Next mi Set k = Nothing End Sub ================================================ FILE: __Arch/Classes/class-project/cls_arrCalendarSettings.vb ================================================ Option Explicit Private p_top_row As Long Private p_bottom_row As Long Private p_left_col As Long Private p_right_col As Long Private p_sonstiges_pro_BA As Double Private p_verhaltnis_baukosten_planer As Double Private p_vertriebsstart As Date Private p_vertriebsstart_col_num As Long Public Property Let Vertriebsstart_Col(l_vertriebsstart_col As Long) p_vertriebsstart_col_num = l_vertriebsstart_col End Property Public Property Get Vertriebsstart_Col() As Long Vertriebsstart_Col = p_vertriebsstart_col_num End Property Public Property Let Vertriebsstart(date_vertriebsstart As Date) p_vertriebsstart = date_vertriebsstart End Property Public Property Get Vertriebsstart() As Date Vertriebsstart = p_vertriebsstart End Property Public Property Get LengthLeftToRight() As Long LengthLeftToRight = RightCol - LeftCol End Property Public Property Get LengthTopToBottom() As Long LengthTopToBottom = BottomRow - TopRow End Property Public Property Let VerhaltnisBaukostenToPlanerkosten(dbl_verhaltnis As Double) p_verhaltnis_baukosten_planer = dbl_verhaltnis End Property Public Property Get VerhaltnisBaukostenToPlanerkosten() As Double VerhaltnisBaukostenToPlanerkosten = p_verhaltnis_baukosten_planer End Property Public Property Let SonstigesProBA(dbl_sonstiges_money As Double) p_sonstiges_pro_BA = dbl_sonstiges_money End Property Public Property Get SonstigesProBA() As Double SonstigesProBA = p_sonstiges_pro_BA End Property Public Property Let TopRow(l_top_row As Long) p_top_row = l_top_row End Property Public Property Get TopRow() As Long TopRow = p_top_row End Property Public Property Let BottomRow(l_bottom_row As Long) p_bottom_row = l_bottom_row End Property Public Property Get BottomRow() As Long BottomRow = p_bottom_row End Property Public Property Let LeftCol(l_left_col As Long) p_left_col = l_left_col End Property Public Property Get LeftCol() As Long LeftCol = p_left_col End Property Public Property Let RightCol(l_right_col As Long) p_right_col = l_right_col End Property Public Property Get RightCol() As Long RightCol = p_right_col End Property ================================================ FILE: __Arch/Classes/class-project/cls_arr_Choice.vb ================================================ Option Explicit Private p_investor As String Private p_region As String Private p_standort As String Private p_project As String Private p_ba_number As Long Private p_global As Boolean Public Property Get Investor() As String Investor = p_investor End Property Public Property Let Investor(str_investor_type As String) p_investor = str_investor_type End Property Public Property Get Region() As String Region = p_region End Property Public Property Let Region(str_region As String) p_region = str_region p_standort = IIf(str_region = "Wien", "Austria", "Germany") End Property Public Property Get Standort() Standort = p_standort End Property Public Property Get Project() As String Project = p_project End Property Public Property Let Project(str_project As String) p_project = str_project End Property Public Property Get BAnumber() As Long BAnumber = p_ba_number End Property Public Property Let BAnumber(l_ba_number As Long) p_ba_number = l_ba_number End Property Public Property Let GlobalProject(b_is_global As Boolean) p_global = b_is_global End Property Public Property Get GlobalProject() As Boolean GlobalProject = p_global End Property Public Property Get GewerbeGlobal() As Boolean If GlobalProject And Project = type_string_project(enum_project.project_gewerbe) Then GewerbeGlobal = True Else GewerbeGlobal = False End If End Property ================================================ FILE: __Arch/Classes/class-project/mod_Properties.vb ================================================ Option Explicit Public Property Get type_string_project(enum_project) As String Dim arr_helping As Variant arr_helping = Array("Wohnung Project", "Gewerbe Project", "Beides") type_string_project = VBA.CStr(arr_helping(enum_project)) End Property Public Property Get type_string_standort(enum_standort) As String Dim arr_helping As Variant arr_helping = Array("Munchen", "Hamburg", "Berlin", "Nurnberg", "Frankfurt", "Wien") type_string_standort = VBA.CStr(arr_helping(enum_standort)) End Property Public Property Get type_string_investor(enum_investors) As String Dim arr_helping As Variant arr_helping = Array("Public Fund", "Private Fund") type_string_investor = VBA.CStr(arr_helping(enum_investors)) End Property ================================================ FILE: __Arch/Classes/class-project/mod_PublicAndEnums ================================================ Option Explicit Enum enum_investors inv_Public inv_Private End Enum Enum enum_standort standort_Berlin standort_Hamburg standort_Nurnberg standort_Munchen standort_Frankfurt standort_Vienna End Enum Enum enum_project project_wohnung project_gewerbe project_beides End Enum Enum enum_BA BA_0 BA_1 BA_2 BA_3 BA_4 BA_5 BA_6 BA_7 BA_8 BA_9 BA_10 End Enum Public my_choice As cls_arrChoice ================================================ FILE: __Arch/Classes/class-project/mod_current.vb ================================================ Option Explicit Sub Load_Data_To_Object() Set my_choice = New cls_arrChoice my_choice.Investor = type_string_investor(enum_investors.inv_Private) my_choice.Region = type_string_standort(enum_standort.standort_Vienna) my_choice.Project = type_string_project(enum_project.project_gewerbe) my_choice.BAnumber = enum_BA.BA_10 my_choice.GlobalProject = True End Sub Sub Display_Data_From_Object() Debug.Print my_choice.Investor Debug.Print my_choice.Standort Debug.Print my_choice.Region Debug.Print my_choice.Project Debug.Print my_choice.BAnumber Debug.Print my_choice.GlobalProject Debug.Print my_choice.GewerbeGlobal End Sub ================================================ FILE: __Arch/Classes/class-project-customized/customized_procedure.vb ================================================ Public Sub PrintProperties(my_object As Object) 'Tools - References - TypeLib Information Dim mi As TLI.MemberInfo Dim ti As TLI.TypeInfo Dim t As TLI.TLIApplication Set t = New TLI.TLIApplication Set ti = t.InterfaceInfoFromObject(my_object) Debug.Print "***********************" For Each mi In ti.Members '0 is for GET Properties, '1 is for LET Properties 'Change accordingly If mi.ReturnType.PointerLevel = 0 Then Debug.Print mi.name & vbCrLf; CallByName(my_object, mi.name, VbGet) & vbCrLf End If Next mi Debug.Print "***********************" Set my_object = Nothing End Sub ================================================ FILE: __Arch/Classes/class-project-improved/cls_arrCalendar.vb ================================================ Option Explicit Private p_top_row As Long Private p_bottom_row As Long Private p_left_col As Long Private p_right_col As Long Public Property Let TopRow(l_top_row As Long) p_top_row = l_top_row End Property Public Property Get TopRow() As Long TopRow = p_top_row End Property Public Property Let BottomRow(l_bottom_row As Long) p_bottom_row = l_bottom_row End Property Public Property Get BottomRow() As Long BottomRow = p_bottom_row End Property Public Property Let LeftCol(l_left_col As Long) p_left_col = l_left_col End Property Public Property Get LeftCol() As Long LeftCol = p_left_col End Property Public Property Let RightCol(l_right_col As Long) p_right_col = l_right_col End Property Public Property Get RightCol() As Long RightCol = p_right_col End Property ================================================ FILE: __Arch/Classes/class-project-improved/cls_arrChoice.vb ================================================ Option Explicit Private p_investor As String Private p_region As String Private p_standort As String Private p_project As String Private p_ba_number As Long Private p_global As Boolean Public Property Get Investor() As String Investor = p_investor End Property Public Property Let Investor(str_investor_type As String) p_investor = str_investor_type End Property Public Property Get Region() As String Region = p_region End Property Public Property Let Region(ByVal str_region As String) p_region = str_region End Property Public Property Let Standort(ByVal str_standort As String) p_standort = str_standort End Property Public Property Get Standort() As String Standort = p_standort End Property Public Property Get Project() As String Project = p_project End Property Public Property Let Project(str_project As String) p_project = str_project End Property Public Property Get BAnumber() As Long BAnumber = p_ba_number End Property Public Property Let BAnumber(l_ba_number As Long) p_ba_number = l_ba_number End Property Public Property Let GlobalProject(b_is_global As Boolean) p_global = b_is_global End Property Public Property Get GlobalProject() As Boolean GlobalProject = p_global End Property Public Property Get GewerbeGlobal() As Boolean If GlobalProject And Project = [set_abbreviation_gewerbe] Then GewerbeGlobal = True Else GewerbeGlobal = False End If End Property ================================================ FILE: __Arch/Classes/class-project-improved/sandbox.vb ================================================ Option Explicit Public my_choice As cls_arrChoice 'vitosh Sub Load_Data_To_Object() Dim s_data As String Set my_choice = New cls_arrChoice If tbl_Input.opt_publikum Then my_choice.Investor = [set_abbreviation_pub] ElseIf tbl_Input.opt_institutionen Then my_choice.Investor = [set_abbreviation_insti] End If If tbl_Input.opt_de Then my_choice.Standort = [set_abbreviation_ger] ElseIf tbl_Input.opt_os Then my_choice.Standort = [set_abbreviation_aus] ElseIf tbl_Input.opt_fr Then my_choice.Standort = [set_abbreviation_fra] End If If tbl_Input.opt_stadt1 And tbl_Input.opt_stadt1 = [set_vie_name] Then my_choice.Region = [set_vie_name] Else If tbl_Input.opt_stadt1 Then my_choice.Region = [set_muc_name] ElseIf tbl_Input.opt_stadt2 Then my_choice.Region = [set_han_name] ElseIf tbl_Input.opt_stadt3 Then my_choice.Region = [set_bln_name] ElseIf tbl_Input.opt_stadt4 Then my_choice.Region = [set_nbg_name] ElseIf tbl_Input.opt_stadt5 Then my_choice.Region = [set_ffm_name] End If End If If tbl_Input.opt_wohnung Then my_choice.Project = [set_abbreviation_wohnungen] ElseIf tbl_Input.opt_gewerbe Then my_choice.Project = [set_abbreviation_gewerbe] ElseIf tbl_Input.opt_wohnung Then my_choice.Project = [set_abbreviation_beides] End If my_choice.BAnumber = tbl_Input.cb_ba_number my_choice.GlobalProject = tbl_Input.chb_global End Sub Sub Display_Data_From_Object() Debug.Print my_choice.Investor Debug.Print my_choice.Standort Debug.Print my_choice.Region Debug.Print my_choice.Project Debug.Print my_choice.BAnumber Debug.Print my_choice.GlobalProject Debug.Print my_choice.GewerbeGlobal 'Set my_choice = Nothing End Sub ================================================ FILE: __Arch/FixSums.vb ================================================ '--------------------------------------------------------------------------------------- ' Procedure : FixSums ' Author : v.doynov ' Date : 18.09.2015 ' Purpose : Fixes the formulas in the sums as per the *******. '--------------------------------------------------------------------------------------- Public Sub FixSums(ByRef r_summen As Range, ByVal l_ba_value As Long) Dim my_cell As Range For Each my_cell In r_summen my_cell.FormulaR1C1 = "=SUM(R[-10]C:R[-" & 10 - l_ba_value + 1 & "]C)" Next my_cell End Sub ================================================ FILE: __Arch/FormWithAnInstanceVBA/Form003/clsSummaryPresenter.vb ================================================ Option Explicit Private WithEvents objSummaryForm As frmMain Private Sub Class_Initialize() Set objSummaryForm = New frmMain End Sub Private Sub Class_Terminate() Set objSummaryForm = Nothing End Sub Public Sub Show() If Not objSummaryForm.Visible Then objSummaryForm.Show vbModeless objSummaryForm.InformationText = "Press Run to Start" objSummaryForm.InformationCaption = "Starting" End If End Sub Public Sub Hide() If objSummaryForm.Visible Then objSummaryForm.Hide End Sub Public Sub ChangeLabelAndCaption(strLabelInfo As String, strCaption As String) objSummaryForm.InformationText = strLabelInfo objSummaryForm.InformationCaption = strCaption objSummaryForm.Repaint End Sub Private Sub objSummaryForm_OnRunReport() MainGenerateReport Refresh End Sub Private Sub objSummaryForm_OnExit() Hide End Sub Public Sub Refresh() With objSummaryForm .lblInfo = "Ready" .Caption = "Task performed" End With End Sub ================================================ FILE: __Arch/FormWithAnInstanceVBA/Form003/frmMain.vb ================================================ Option Explicit Public Event OnRunReport() Public Event OnExit() Public Property Get InformationText() As String InformationText = lblInfo.Caption End Property Public Property Let InformationText(ByVal value As String) lblInfo.Caption = value End Property Public Property Get InformationCaption() As String InformationCaption = Caption End Property Public Property Let InformationCaption(ByVal value As String) Caption = value End Property Private Sub btnRun_Click() RaiseEvent OnRunReport End Sub Private Sub btnExit_Click() RaiseEvent OnExit End Sub Private Sub UserForm_QueryClose(CloseMode As Integer, Cancel As Integer) If CloseMode = vbFormControlMenu Then Cancel = True Hide End If End Sub ================================================ FILE: __Arch/FormWithAnInstanceVBA/Form003/modMain.vb ================================================ Option Explicit Private objPresenter As clsSummaryPresenter Public Sub MainGenerateReport() Call objPresenter.ChangeLabelAndCaption("Starting and running...", "Running...") GenerateNumbers End Sub Public Sub GenerateNumbers() Dim lngLong As Long Dim lngLong2 As Long tblMain.Cells.Clear For lngLong = 1 To 4 For lngLong2 = 1 To 1 tblMain.Cells(lngLong, lngLong2) = lngLong * lngLong2 Next lngLong2 Next lngLong End Sub Public Sub ShowMainForm() 'CTRL+E If (objPresenter Is Nothing) Then Set objPresenter = New clsSummaryPresenter End If objPresenter.Show End Sub ================================================ FILE: __Arch/FormWithAnInstanceVBA/clsSummaryPresenter.vb ================================================ Option Explicit Private WithEvents objSummaryForm As frmMain Private Sub Class_Initialize() Set objSummaryForm = New frmMain End Sub Private Sub Class_Terminate() Set objSummaryForm = Nothing End Sub Public Sub Show() If Not objSummaryForm.Visible Then objSummaryForm.Show vbModeless objSummaryForm.lblInfo = "Press Run to Start" objSummaryForm.Caption = "Starting" End If End Sub Public Sub Hide() If objSummaryForm.Visible Then objSummaryForm.Hide End Sub Public Sub ChangeLabelAndCaption(strLabelInfo As String, strCaption As String) objSummaryForm.lblInfo = strLabelInfo objSummaryForm.Caption = strCaption objSummaryForm.Repaint End Sub Private Sub objSummaryForm_OnRunReport() MainGenerateReport Refresh End Sub Private Sub objSummaryForm_OnExit() Hide End Sub Public Sub Refresh() With objSummaryForm .lblInfo = "Ready" .Caption = "Task performed" End With End Sub ================================================ FILE: __Arch/FormWithAnInstanceVBA/frmMain.vb ================================================ Option Explicit Public Event OnRunReport() Public Event OnExit() Private Sub btnRun_Click() RaiseEvent OnRunReport End Sub Private Sub btnExit_Click() RaiseEvent OnExit End Sub ================================================ FILE: __Arch/FormWithAnInstanceVBA/modMain.vb ================================================ Option Explicit Private objPresenter As clsSummaryPresenter Public Sub MainGenerateReport() Call objPresenter.ChangeLabelAndCaption("Starting and running...", "Running...") GenerateNumbers End Sub Public Sub GenerateNumbers() Dim lngLong As Long Dim lngLong2 As Long tblMain.Cells.Clear For lngLong = 1 To 3000 For lngLong2 = 1 To 10 tblMain.Cells(lngLong, lngLong2) = lngLong * lngLong2 Next lngLong2 Next lngLong End Sub Public Sub ShowMainForm() 'CTRL+E If (objPresenter Is Nothing) Then Set objPresenter = New clsSummaryPresenter objPresenter.Show End Sub ================================================ FILE: __Arch/FormatMyCell.vb ================================================ Public Sub FormatMyCell(ByRef my_cell As range, Optional b_as_currency As Boolean = False, _ Optional b_as_date As Boolean = False, _ Optional b_as_dark As Boolean = False, _ Optional b_as_din As Boolean = False) If b_as_currency Then my_cell.NumberFormat = "#,##0.00 $" End If If b_as_date Then my_cell.NumberFormat = "[$-407]mmm/ yy;@" End If If b_as_dark Then my_cell.Interior.ThemeColor = xlThemeColorDark1 my_cell.Interior.TintAndShade = -0.249946592608417 End If If b_as_din Then my_cell.Font.Name = "DIN-Light" End If End Sub ================================================ FILE: __Arch/Hex.vb ================================================ Private Sub tbx_hex_Change() On Error Resume Next Dim s_write As String Dim s_hour$, s_min$, s_sec$ Me.lbl_hex = Val("&H" & Me.tbx_hex) If Len(Me.lbl_hex) = 6 Then s_hour = Left(Me.lbl_hex, 2) s_min = Mid(Me.lbl_hex, 3, 2) Debug.Print Me.lbl_hex Debug.Print s_min s_sec = Right(Me.lbl_hex, 2) s_write = s_hour & ":" & s_min & ":" & s_sec Me.lbl_hex = s_write End If On Error GoTo 0 End Sub Private Sub UserForm_Activate() Dim l_files As Long With Me .Top = CLng((Application.Height / 2 + Application.Top) - .Height / 2) .Left = CLng((Application.Width / 2 + Application.Left) - .Width / 2) End With Me.BackColor = ActiveSheet.Tab.Color If (ActiveSheet.Tab.Color = False) Then Unload Me frm_run.tbx_hex.Visible = b_value_in_array(Environ("Username"), ADMINS, True) frm_run.lbl_hex.BackColor = ActiveSheet.Tab.Color l_files = lng_files_to_create If l_files = 1 Then frm_run.lbl_hex = l_files & " Datei zu generieren." Else frm_run.lbl_hex = l_files & " Dateien zu generieren." End If End Sub ================================================ FILE: __Arch/HideRange.vb ================================================ Public Sub HideRange(r_range_to_hide As Range, l_ba_value As Long) Dim my_cell As Range For Each my_cell In r_range_to_hide If my_cell.Row > l_ba_value Then my_cell.Interior.Pattern = xlGray8 my_cell.Font.ThemeColor = xlThemeColorDark1 Else my_cell.Interior.Pattern = xlAutomatic my_cell.Font.ColorIndex = xlAutomatic End If Next my_cell r_range_to_hide.Borders(xlEdgeTop).LineStyle = xlContinuous r_range_to_hide.Borders(xlEdgeLeft).LineStyle = xlContinuous r_range_to_hide.Borders(xlEdgeBottom).LineStyle = xlContinuous r_range_to_hide.Borders(xlEdgeRight).LineStyle = xlContinuous End Sub ================================================ FILE: __Arch/HideShowComments.vb ================================================ Sub HideShowComments(Optional b_show_comments As Boolean = False) On Error Resume Next For Each current_cell In Range("A1:AO1000") current_cell.Comment.Visible = b_show_comments Next current_cell On Error GoTo 0 End Sub ================================================ FILE: __Arch/NamedRanges.vb ================================================ Sub change_all_names() Dim i As Long Dim s As String Dim s_old As String Dim s_new As String For i = 1 To ActiveWorkbook.Names.Count ' Debug.Print ActiveWorkbook.Names(i).name ' Debug.Print ActiveWorkbook.Names(i).RefersToR1C1 ' Debug.Print ActiveWorkbook.Names(i) If InStr(1, ActiveWorkbook.Names(i), "old", vbTextCompare) Then s_old = ActiveWorkbook.Names(i).RefersToR1C1 s_new = Replace(s_old, "old", "") Debug.Print s_new With ActiveWorkbook.Names(ActiveWorkbook.Names(i).name) .RefersToR1C1 = s_new End With End If Next i End Sub Public Sub MakeNegativesOne(l_col As Long) Dim l_counter As Long Dim b_negative As Long Dim my_cell As Range Dim my_first_negative As Range Dim dbl_negative_sum As Double For l_counter = 1 To 13 Set my_cell = Cells(l_col, l_counter) If my_cell < 0 And my_cell.HasFormula Then dbl_negative_sum = dbl_negative_sum + my_cell.Value If Not b_negative Then b_negative = True Set my_first_negative = my_cell End If my_cell = 0 End If Next l_counter If b_negative Then my_first_negative = dbl_negative_sum End If End Sub Public Sub NegativeSelection(Optional my_rng As Variant) Dim my_cell As Range If IsMissing(my_rng) Then Set my_rng = Selection For Each my_cell In my_rng my_cell = my_cell * -1 Next my_cell End Sub ================================================ FILE: __Arch/OpenedExcelInfo.vb ================================================ ' Information for opened Excel Files ' Other Excel Files information ' Opened Excel files ' Excel files count ' Excel count Public Sub InfoForExcel() Dim objList As Object Dim strProcessName As String strProcessName = "EXCEL.EXE" Set objList = GetObject("winmgmts:").ExecQuery("select * from win32_process where name='" & strProcessName & "'") If objList.Count > 1 Then MsgBox "Sie haben " & objList.Count & " eröffneten Excel Dateien." & vbCrLf & _ "Bitte schließen Sie alles, außer der aktuellen Anwendung." End If End Sub ================================================ FILE: __Arch/OutlookRelated.vb ================================================ Sub LoopFoldersInInbox() Dim ns As Object Dim objFolder As Object Dim objSubfolder As Object Set ns = GetObject("", "Outlook.Application").GetNamespace("MAPI") Set objFolder = ns.GetDefaultFolder(6) ' 6 is equal to olFolderInbox For Each objSubfolder In objFolder.Folders Debug.Print objSubfolder.name Debug.Print objSubfolder.Items.Count Next objSubfolder End Sub ================================================ FILE: __Arch/Recursion.vb ================================================ Option Explicit '--------------------------------------------------------------------------------------- ' Method : TestMe ' Date : 22.01.2018 ' Purpose: Do not try to sum array like this :) ' Sample for recursion sum. '--------------------------------------------------------------------------------------- Public Sub TestMe() Debug.Print SumArrayRecursion(Array(1, 2, 4, 8)) End Sub Public Function SumArrayRecursion(arr As Variant) As Long Dim cnt As Long Dim newArr As Variant If LBound(arr) = UBound(arr) Then SumArrayRecursion = arr(0) Exit Function End If ReDim newArr(UBound(arr) - 1) For cnt = LBound(newArr) To UBound(newArr) newArr(cnt) = arr(cnt) Next cnt Debug.Print printArray(newArr) SumArrayRecursion = SumArrayRecursion(newArr) + newArr(UBound(newArr)) End Function Public Function printArray(arr As Variant) As String Dim cnt As Long For cnt = LBound(arr) To UBound(arr) printArray = printArray & " " & arr(cnt) Next cnt End Function ================================================ FILE: __Arch/RelativePath.vb ================================================ Option Explicit Sub TestMe() Debug.Print get_relative("U:\DB_DATA\HISTORY_LOG.xlsx") Debug.Print get_relative("U:\DB_DATA\HISTORY_LOG.xlsx", 2) End Sub Public Function get_relative(str_path As String, Optional l_number As Long = 1) As String Dim str_result As String Dim l_start As Long Dim l_counter As Long For l_counter = 1 To l_number l_start = InStr(l_start + 1, str_path, "\") Next l_counter get_relative = Mid(str_path, InStr(l_start, str_path, "\")) End Function ================================================ FILE: __Arch/RemoveAllItemsFromListBox.vb ================================================ Private Sub RemoveAllItemsFromListBox(lb_object As Object) Dim l_counter As Long For l_counter = 1 To lb_object.ListCount lb_object.RemoveItem 0 Next l_counter End Sub ================================================ FILE: __Arch/SaveAs.vb ================================================ Private Sub btn_save_as_Click() Dim b_saved As Boolean b_saved = Application.Dialogs(xlDialogSaveAs).Show If Not b_saved Then MsgBox "Die Datei wurde nicht gespeichert!", vbInformation, [ale] End Sub ================================================ FILE: __Arch/SmallExcelFormats.vb ================================================ #.##0,00 "€ / qm" #.##0,00 "qm" ================================================ FILE: __Arch/TDD_example.vb ================================================ Option Explicit Public Sub TDD() Call SetToZero Call SetToDefault Call tbl_main.cmd_hoai_Click Call RunMe(1) Call TDD_1 Call TDD_2 End Sub Public Sub TDD_1() Call TDD_1A Call TDD_1B Call TDD_1C End Sub Public Sub TDD_2() Call TDD_2A Call TDD_2B End Sub Public Sub TDD_2B() Dim my_arr As Variant Dim specs As New SpecSuite Dim l_counter As Long Dim l_size As Long: l_size = 4 Dim l_row As Long Dim l_col As Long On Error Resume Next Call OnStart my_arr = arr_fill_predefined_test_2B_rng_C1F42 For l_counter = 0 To UBound(my_arr) - 1 Step 1 l_row = l_counter \ l_size l_col = l_counter Mod l_size specs.It("2B_01_" & l_row + 1 & "_" & l_col + 2).Expect(my_arr(l_counter + 1)).ToEqual tbl_calendar.[C1].Offset(l_row, l_col).value 'Debug.Print tbl_calendar.[C1].Offset(l_row, l_col).Address 'tbl_calendar.[C1].Offset(l_row, l_col).Select Next l_counter InlineRunner.RunSuite specs Call specs.TotalTests Call OnEnd On Error GoTo 0 End Sub '--------------------------------------------------------------------------------------- ' Method : MakeAllValues ' Author : v.doynov ' Date : 07.11.2016 ' Purpose: Select the range, for which you want the TDD code. '--------------------------------------------------------------------------------------- Public Sub MakeAllValues() Dim my_cell As Range Dim l_counter As Long Dim str As String For Each my_cell In Selection Call Increment(l_counter) str = vbTab & "my_arr(" & l_counter & ")= " If Len(my_cell) > 0 Then If IsDate(my_cell) Then str = str & "CDate(""" & my_cell & """)" Else If Not IsNumeric(my_cell) Then str = str & """" & my_cell & """" Else str = str & change_commas(my_cell.value) End If End If Else If my_cell.HasFormula Then str = str & """""" Else str = str & 0 End If End If Debug.Print str Next my_cell End Sub Public Sub TDD_2A() Dim my_arr As Variant Dim specs As New SpecSuite Dim l_counter As Long On Error Resume Next Call OnStart 'Col F - Honorar my_arr = arr_fill_predefined_test_2A_colF For l_counter = 1 To UBound(my_arr) Step 1 specs.It("2A_01F_" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[F1].Offset(l_counter - 1).value Next l_counter 'Col I - Mar 15 my_arr = arr_fill_predefined_test_2A_colI For l_counter = 1 To UBound(my_arr) Step 1 specs.It("2A_02I_" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[I1].Offset(l_counter - 1).value Next l_counter 'Col M - Aug 15 my_arr = arr_fill_predefined_test_2A_colM Call Increment(l_counter) For l_counter = 1 To UBound(my_arr) Step 1 specs.It("2A_03M_" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[M1].Offset(l_counter - 1).value Next l_counter 'Col BK - Oct 19 my_arr = arr_fill_predefined_test_2A_colBK For l_counter = 1 To UBound(my_arr) Step 1 specs.It("2A_04BK_" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[BK1].Offset(l_counter - 1).value Next l_counter 'Col AL - Sep 17 my_arr = arr_fill_predefined_test_2A_colAL For l_counter = 1 To UBound(my_arr) Step 1 specs.It("2A_05AL_" & l_counter).Expect(my_arr(l_counter)).ToEqual tbl_calendar.[AL1].Offset(l_counter - 1).value Next l_counter InlineRunner.RunSuite specs Call specs.TotalTests Call OnEnd On Error GoTo 0 End Sub Public Sub MakeValues() Dim my_cell As Range Dim str As String Dim l_counter As Long For Each my_cell In Selection Call Increment(l_counter) str = "my_arr(" & l_counter & ")= " If Len(my_cell) > 0 Then str = str & change_commas(my_cell.value) Else str = str & 0 End If Debug.Print str Next my_cell End Sub Public Sub SetToZero() Dim arr_dates(12) As Date Dim arr_values(16) As Double Call OnStart tbl_main.tb_show_hide_further = True tbl_main.cmb_ba = 2 tbl_main.cmb_land = "Deutschland" tbl_main.chb_zweimal = True tbl_main.chb_jump = False tbl_main.chb_insti = False 'Set dates tbl_main.[m_buying_date] = "" tbl_main.[m_end_date] = "" tbl_main.[e2] = "" tbl_main.[e3] = "" tbl_main.[f2] = "" tbl_main.[f3] = "" tbl_main.[g2] = "" tbl_main.[g3] = "" tbl_main.[h2] = "" tbl_main.[h3] = "" tbl_main.[k2] = "" tbl_main.[l2] = "" 'Set values tbl_main.[i2] = "" tbl_main.[i3] = "" tbl_main.[j2] = "" tbl_main.[j3] = "" tbl_main.[e18] = "" tbl_main.[e19] = "" tbl_main.[s54] = "" tbl_main.[s55] = "" tbl_main.[t54] = "" tbl_main.[t55] = "" tbl_main.[u54] = "" tbl_main.[u55] = "" tbl_main.[v54] = "" tbl_main.[v55] = "" tbl_main.[i92] = "" tbl_main.[i93] = "" Call OnEnd 'Call HOAI calculation On Error GoTo 0 Exit Sub End Sub Public Sub SetToDefault() If [set_in_production] Then On Error GoTo SetToDefault_Error Dim arr_dates(12) As Date Dim arr_values(16) As Double Call OnStart tbl_main.tb_show_hide_further = True tbl_main.cmb_ba = 2 tbl_main.cmb_land = "Deutschland" tbl_main.chb_zweimal = True tbl_main.chb_jump = False tbl_main.chb_insti = False 'Set dates arr_dates(1) = "01.03.2015" arr_dates(2) = "01.10.2019" arr_dates(3) = "01.12.2016" arr_dates(4) = "01.12.2016" arr_dates(5) = "01.06.2018" arr_dates(6) = "01.07.2018" arr_dates(7) = "01.08.2018" arr_dates(8) = "01.10.2018" arr_dates(9) = "01.09.2017" arr_dates(10) = "01.05.2017" arr_dates(11) = "01.01.2016" arr_dates(12) = "01.07.2015" tbl_main.[main_objektname] = "Bagelstrasse Duesseldorf" tbl_main.[m_buying_date] = arr_dates(1) tbl_main.[m_end_date] = arr_dates(2) tbl_main.[e2] = arr_dates(3) tbl_main.[e3] = arr_dates(4) tbl_main.[f2] = arr_dates(5) tbl_main.[f3] = arr_dates(6) tbl_main.[g2] = arr_dates(7) tbl_main.[g3] = arr_dates(8) tbl_main.[h2] = arr_dates(9) tbl_main.[h3] = arr_dates(10) tbl_main.[k2] = arr_dates(11) tbl_main.[l2] = arr_dates(12) 'Set values arr_values(1) = 3417 arr_values(2) = 3644 arr_values(3) = 404 arr_values(4) = 404 arr_values(5) = 1234567 arr_values(6) = 12345678 arr_values(7) = 123456 arr_values(8) = 100000 arr_values(9) = 250000 arr_values(10) = 270000 arr_values(11) = 350000 arr_values(12) = 450000 arr_values(13) = 300000 arr_values(14) = 350000 arr_values(15) = 150000 arr_values(16) = 160000 tbl_main.[i2] = arr_values(1) tbl_main.[i3] = arr_values(2) tbl_main.[j2] = arr_values(3) tbl_main.[j3] = arr_values(4) tbl_main.[e18] = arr_values(5) tbl_main.[e19] = arr_values(6) tbl_main.[s54] = arr_values(7) tbl_main.[s55] = arr_values(8) tbl_main.[t54] = arr_values(9) tbl_main.[t55] = arr_values(10) tbl_main.[u54] = arr_values(11) tbl_main.[u55] = arr_values(12) tbl_main.[v54] = arr_values(13) tbl_main.[v55] = arr_values(14) tbl_main.[i92] = arr_values(15) tbl_main.[i93] = arr_values(16) Call OnEnd 'Call HOAI calculation On Error GoTo 0 Exit Sub SetToDefault_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SetToDefault of Sub mod_TDD" End Sub Public Sub HowToList() Dim obj_list As cls_vbaList Set obj_list = New cls_vbaList obj_list.Add (30) obj_list.Add (3) obj_list.Add (355) obj_list.Add (5) obj_list.Add (1) obj_list.Add (40) Debug.Print obj_list.Contains(30) Debug.Print obj_list.Exists(30) Debug.Print obj_list.Items(0) obj_list.Sort Debug.Print obj_list.Items(0) Debug.Print obj_list.Find(3) Debug.Print obj_list.Find(30) Debug.Print obj_list.LastIndexOf(355) Set obj_list = Nothing End Sub Public Sub TDD_1C() On Error Resume Next Dim specs As New SpecSuite Dim obj_total_test As New cls_Total Dim obj_total_cal_test As New cls_TotalCalendar Dim var_list As New cls_vbaList Call OnStart specs.It("C001").Expect(obj_total_test.LeftSideCols).ToEqual 7 specs.It("C002").Expect(obj_total_test.BA_Number).ToEqual CLng(tbl_main.[cmb_ba].value) specs.It("C003").Expect(obj_total_test.B_Insti).ToEqual CBool(tbl_main.[chb_insti]) tbl_main.[chb_insti] = True specs.It("C004").Expect(obj_total_test.MarkCost1).ToEqual CStr([set_total_mark_2]) specs.It("C005").Expect(obj_total_test.MarkCost2).ToEqual CStr([set_total_mark_4]) specs.It("C006").Expect(obj_total_test.MarkCost3).ToEqual CStr([set_total_mark_6]) tbl_main.[chb_insti] = False specs.It("C007").Expect(obj_total_test.MarkCost1).ToEqual CStr([set_total_mark_1]) specs.It("C008").Expect(obj_total_test.MarkCost2).ToEqual CStr([set_total_mark_3]) specs.It("C009").Expect(obj_total_test.MarkCost3).ToEqual CStr([set_total_mark_5]) specs.It("C010").Expect(obj_total_test.MarkCost1).ToNotEqual CStr([set_total_mark_2]) specs.It("C011").Expect(obj_total_test.MarkCost2).ToNotEqual CStr([set_total_mark_4]) specs.It("C012").Expect(obj_total_test.MarkCost3).ToNotEqual CStr([set_total_mark_6]) specs.It("C013").Expect(obj_total_test.CurrentLine).ToNotEqual 2 specs.It("C014").Expect(obj_total_test.CurrentLine).ToEqual 0 Call obj_total_test.IncrementCurrentLine specs.It("C015").Expect(obj_total_test.CurrentLine).ToEqual 1 Call obj_total_test.IncrementCurrentLine specs.It("C016").Expect(obj_total_test.CurrentLine).ToEqual 2 obj_total_test.CurrentLine = 12 specs.It("C017").Expect(obj_total_test.CurrentLine).ToEqual 12 specs.It("C018").Expect(obj_total_test.MarkCostTitle).ToEqual CStr([set_total_mark_title]) specs.It("C019").Expect(obj_total_test.CurrentLine).ToNotEqual CStr([set_total_mark_title] & "1") specs.It("C020").Expect(obj_total_test.LastRow).ToEqual last_row(tbl_totals.Name) specs.It("C021").Expect(obj_total_test.LastRow).ToNotEqual 9999 var_list.Add 5 var_list.Add 10 var_list.Add 15 var_list.Add 20 Set obj_total_cal_test.PlanerkostenSrc = var_list specs.It("C022").Expect(obj_total_cal_test.PlanerkostenSrc.Items(0)).ToEqual 5 specs.It("C023").Expect(obj_total_cal_test.PlanerkostenSrc.Items(1)).ToEqual 10 specs.It("C024").Expect(obj_total_cal_test.PlanerkostenSrc.Items(2)).ToEqual 15 specs.It("C025").Expect(obj_total_cal_test.PlanerkostenSrc.Items(3)).ToEqual 20 specs.It("C026").Expect(obj_total_cal_test.PlanerkostenSrc.Items(0)).ToNotEqual 5 + 1 specs.It("C027").Expect(obj_total_cal_test.PlanerkostenSrc.Items(1)).ToNotEqual 10 + 1 specs.It("C028").Expect(obj_total_cal_test.PlanerkostenSrc.Items(2)).ToNotEqual 15 + 1 InlineRunner.RunSuite specs Call specs.TotalTests Call OnEnd On Error GoTo 0 End Sub Public Sub TDD_1B() On Error Resume Next Dim specs As New SpecSuite Call OnStart specs.It("B001").Expect([set_in_production]).ToEqual True specs.It("B002").Expect([set_in_production]).ToNotEqual False InlineRunner.RunSuite specs Call specs.TotalTests Call OnEnd On Error GoTo 0 End Sub Public Sub TDD_1A() On Error Resume Next Dim specs As New SpecSuite Dim obj_calendar As New cls_Calendar Dim obj_dat As New cls_Dates Dim obj_sav As New cls_Saver Dim obj_input_dates As New cls_InputDates Dim obj_test_land As New cls_Land Dim l_value As Long Dim d_value As Date Dim str_initial As String Call OnStart Set obj_con = New cls_Const specs.It("A001").Expect(obj_calendar.UPPER_ROW).ToEqual 4 specs.It("A002").Expect(obj_calendar.ROWS_TAKEN).ToEqual 3 obj_calendar.current_row = 111 specs.It("A003").Expect(obj_calendar.current_row).ToEqual 111 obj_calendar.IncrementRow obj_calendar.IncrementRow specs.It("A004").Expect(obj_calendar.current_row).ToNotEqual 111 obj_calendar.IncrementRow specs.It("A005").Expect(obj_calendar.current_row).ToEqual 114 obj_calendar.AddToPercentageLines (10) obj_calendar.AddToPercentageLines (15) obj_calendar.AddToPercentageLines (20) obj_calendar.AddToPercentageLines (25) specs.It("A006").Expect(obj_calendar.percentage_lines(1)).ToEqual 10 specs.It("A007").Expect(obj_calendar.percentage_lines(2)).ToEqual 15 specs.It("A008").Expect(obj_calendar.percentage_lines(3)).ToNotEqual 20 + 1 specs.It("A009").Expect(obj_calendar.percentage_lines(4)).ToEqual 25 obj_calendar.AddToLines (100) obj_calendar.AddToLines (200) obj_calendar.AddToLines (300) obj_calendar.AddToLines (400) specs.It("A010").Expect(obj_calendar.lines(1)).ToEqual 100 specs.It("A011").Expect(obj_calendar.lines(2)).ToEqual 200 specs.It("A012").Expect(obj_calendar.lines(3)).ToNotEqual 300 + 1 specs.It("A013").Expect(obj_calendar.lines(3)).ToEqual 300 specs.It("A014").Expect(obj_calendar.lines(4)).ToEqual 400 specs.It("A015").Expect(obj_calendar.lines(4)).ToEqual 400 obj_calendar.last_col = 400 specs.It("A016").Expect(obj_calendar.length_of_calendar).ToEqual 400 - obj_con.COLUMNS_TAKEN Dim str_variable As String: str_variable = "BA LP" specs.It("A017").Expect(obj_con.BA_NAME & obj_con.SPACE & obj_con.LP_NAME).ToEqual (str_variable) str_variable = "BA L P" specs.It("A018").Expect(obj_con.BA_NAME & obj_con.SPACE & obj_con.LP_NAME).ToNotEqual (str_variable) specs.It("A019").Expect(generate_honorare_gebaude(100000, 3, True)).ToEqual 15005 specs.It("A020").Expect(generate_honorare_gebaude(100000, 3, False)).ToEqual 16859 specs.It("A021").Expect(generate_honorare_gebaude(100000, 3, True)).ToNotEqual 15005 + 10 specs.It("A022").Expect(generate_honorare_gebaude(100000, 3, False)).ToNotEqual 16859 + 10 specs.It("A023").Expect(generate_honorare_hlse(100000, 2, True)).ToEqual 27150 specs.It("A024").Expect(generate_honorare_hlse(100000, 2, False)).ToEqual 29511 specs.It("A025").Expect(generate_honorare_hlse(5000, 2, True)).ToEqual 2547 specs.It("A026").Expect(generate_honorare_hlse(5000, 2, False)).ToEqual 2768.5 specs.It("A027").Expect(generate_honorare_hlse(4000000, 2, True)).ToEqual 492410 specs.It("A028").Expect(generate_honorare_hlse(4000000, 2, False)).ToEqual 535228 specs.It("A029").Expect(generate_honorare_hlse(4000000, 2, True)).ToNotEqual 492410 - 10 specs.It("A030").Expect(generate_honorare_hlse(4000000, 2, False)).ToNotEqual 535228 - 10 specs.It("A031").Expect(generate_honorare_aussenanlagen(20000, 3, True)).ToEqual 5229 specs.It("A032").Expect(generate_honorare_aussenanlagen(20000, 3, False)).ToEqual 5875 specs.It("A033").Expect(generate_honorare_aussenanlagen(75000, 3, True)).ToEqual 16116 specs.It("A034").Expect(generate_honorare_aussenanlagen(75000, 3, False)).ToEqual 18108 specs.It("A035").Expect(generate_honorare_aussenanlagen(1500000, 3, True)).ToEqual 201261 specs.It("A036").Expect(generate_honorare_aussenanlagen(1500000, 3, False)).ToEqual 226136 specs.It("A037").Expect(generate_honorare_aussenanlagen(1500000, 3, True)).ToNotEqual 201261 + 10 specs.It("A038").Expect(generate_honorare_aussenanlagen(1500000, 3, False)).ToNotEqual 226132 + 10 specs.It("A039").Expect(generate_honorare_tragwerksplannung(10000, 3, True)).ToEqual 2064 specs.It("A040").Expect(generate_honorare_tragwerksplannung(10000, 3, False)).ToEqual 2319.5 specs.It("A041").Expect(generate_honorare_tragwerksplannung(123456, 3, True)).ToEqual 14863.1 specs.It("A042").Expect(generate_honorare_tragwerksplannung(123456, 3, False)).ToEqual 16700.24 specs.It("A043").Expect(generate_honorare_tragwerksplannung(15000000, 3, True)).ToEqual 642943 specs.It("A044").Expect(generate_honorare_tragwerksplannung(15000000, 3, False)).ToEqual 722408 specs.It("A045").Expect(generate_honorare_tragwerksplannung(15000000, 3, True)).ToNotEqual 642943 + 1 specs.It("A046").Expect(generate_honorare_tragwerksplannung(15000000, 3, False)).ToNotEqual 722408 + 1 specs.It("A047").Expect(generate_honorar_brandschutz(969)).ToEqual 8994.56 specs.It("A048").Expect(generate_honorar_brandschutz(2322)).ToEqual 13652.83 specs.It("A049").Expect(generate_honorar_brandschutz(12345.67)).ToEqual 33544.66 specs.It("A050").Expect(generate_honorar_brandschutz(25900.18)).ToEqual 51136.09 ' b_show_msgbox is an optional value, set to true initially. ' The idea is to be false for the tests, thus it does not show a msgbox specs.It("A051").Expect(generate_honorare_tragwerksplannung(10000 - 1, 3, True, b_show_msgbox:=False)).ToEqual -1 specs.It("A052").Expect(generate_honorare_tragwerksplannung(15000000 + 1, 3, True, b_show_msgbox:=False)).ToEqual -10 obj_calendar.last_col = 50 specs.It("A053").Expect(obj_calendar.last_col).ToEqual 50 Set obj_dat = New cls_Dates Call obj_dat.AddEingabeDate("04.02.1999") Call obj_dat.AddEingabeDate("04.02.1998") Call obj_dat.AddEingabeDate("04.02.1995") specs.It("A054").Expect(obj_dat.eingabe_date(1)).ToEqual CDate("04.02.1999") specs.It("A055").Expect(obj_dat.eingabe_date(2)).ToEqual CDate("04.02.1998") specs.It("A056").Expect(obj_dat.eingabe_date(3)).ToEqual CDate("04.02.1995") specs.It("A057").Expect(obj_dat.eingabe_date(2)).ToEqual CDate("04.02.1998") specs.It("A058").Expect(obj_dat.eingabe_date(3)).ToNotEqual CDate("05.02.1999") obj_calendar.last_col = obj_calendar.last_col + obj_calendar.last_col specs.It("A059").Expect(obj_calendar.last_col).ToEqual 100 l_value = tbl_main.cmb_ba.value specs.It("A060").Expect(obj_calendar.ba).ToEqual l_value specs.It("A061").Expect(obj_calendar.ba).ToNotEqual l_value + 1 d_value = DateSerial(tbl_main.cmb_year, tbl_main.cmb_month, 1) specs.It("A062").Expect(obj_calendar.fixed_date).ToEqual d_value specs.It("A063").Expect(obj_calendar.fixed_date).ToNotEqual d_value + 1 d_value = DateDiff("m", [m_start_date], [m_end_date]) specs.It("A064").Expect(obj_calendar.calendar_size_original).ToEqual d_value specs.It("A065").Expect(obj_calendar.calendar_size_original).ToNotEqual d_value + 1 d_value = DateDiff("m", [m_start_date], [main_bau_range_changes_2]) specs.It("A066").Expect(obj_calendar.calendar_size_changed).ToEqual d_value specs.It("A067").Expect(obj_calendar.calendar_size_changed).ToNotEqual d_value + 1 Set obj_sav = New cls_Saver obj_sav.AddRate7 ("12.12.2012") obj_sav.AddRate7 ("12.12.2013") obj_sav.AddRate7 ("12.12.2014") specs.It("A068").Expect(obj_sav.Rate7MF(1)).ToEqual CDate("12.12.2012") specs.It("A069").Expect(obj_sav.Rate7MF(2)).ToEqual CDate("12.12.2013") specs.It("A070").Expect(obj_sav.Rate7MF(3)).ToEqual CDate("12.12.2014") specs.It("A071").Expect(obj_sav.Rate7MF(1)).ToNotEqual CDate("12.12.2015") obj_sav.AddRate6 ("12.5.2012") obj_sav.AddRate6 ("12.6.2013") obj_sav.AddRate6 ("12.7.2014") specs.It("A072").Expect(obj_sav.Rate6BZ(1)).ToEqual CDate("12.5.2012") specs.It("A073").Expect(obj_sav.Rate6BZ(2)).ToEqual CDate("12.6.2013") specs.It("A074").Expect(obj_sav.Rate6BZ(3)).ToEqual CDate("12.7.2014") specs.It("A075").Expect(obj_sav.Rate6BZ(1)).ToNotEqual CDate("12.12.2015") obj_sav.AddBB ("12.1.2012") obj_sav.AddBB ("12.2.2013") obj_sav.AddBB ("12.3.2014") specs.It("A076").Expect(obj_sav.BB(1)).ToEqual CDate("12.1.2012") specs.It("A077").Expect(obj_sav.BB(2)).ToEqual CDate("12.2.2013") specs.It("A078").Expect(obj_sav.BB(3)).ToEqual CDate("12.3.2014") specs.It("A079").Expect(obj_sav.BB(1)).ToNotEqual CDate("12.4.2015") obj_sav.AddEndeRb ("1.5.2012") obj_sav.AddEndeRb ("2.5.2012") obj_sav.AddEndeRb ("3.5.2012") specs.It("A080").Expect(obj_sav.EndeRb(1)).ToEqual CDate("1.5.2012") specs.It("A081").Expect(obj_sav.EndeRb(2)).ToEqual CDate("2.5.2012") specs.It("A082").Expect(obj_sav.EndeRb(3)).ToEqual CDate("3.5.2012") specs.It("A083").Expect(obj_sav.EndeRb(1)).ToNotEqual CDate("2.5.2012") obj_sav.Baueingabe = "6.10.2020" specs.It("A084").Expect(obj_sav.Baueingabe).ToEqual CDate("6.10.2020") obj_sav.Baueingabe = "6.10.2021" specs.It("A085").Expect(obj_sav.Baueingabe).ToEqual CDate("6.10.2021") obj_sav.Baueingabe = "6.10.2022" specs.It("A086").Expect(obj_sav.Baueingabe).ToEqual CDate("6.10.2022") specs.It("A087").Expect(obj_sav.Baueingabe).ToNotEqual CDate("6.10.2023") obj_sav.Baugenehmigung = "6.11.2020" specs.It("A088").Expect(obj_sav.Baugenehmigung).ToEqual CDate("6.11.2020") obj_sav.Baugenehmigung = "6.11.2021" specs.It("A089").Expect(obj_sav.Baugenehmigung).ToEqual CDate("6.11.2021") obj_sav.Baugenehmigung = "6.11.2022" specs.It("A090").Expect(obj_sav.Baugenehmigung).ToEqual CDate("6.11.2022") specs.It("A091").Expect(obj_sav.Baugenehmigung).ToNotEqual CDate("6.11.2023") obj_sav.LetzterTag = "12.12.1960" specs.It("A092").Expect(obj_sav.LetzterTag).ToEqual CDate("12.12.1960") obj_sav.LetzterTag = "12.12.1961" specs.It("A093").Expect(obj_sav.LetzterTag).ToEqual CDate("12.12.1961") obj_sav.LetzterTag = "12.12.1962" specs.It("A094").Expect(obj_sav.LetzterTag).ToEqual CDate("12.12.1962") specs.It("A095").Expect(obj_sav.LetzterTag).ToNotEqual CDate("12.12.1960") obj_sav.Changes = "vit" specs.It("A096").Expect(obj_sav.Changes).ToEqual "vit" obj_sav.Changes = "osh" specs.It("A097").Expect(obj_sav.Changes).ToNotEqual "vit" specs.It("A098").Expect(obj_sav.Changes).ToEqual "vit" & vbCrLf & "osh" obj_sav.AddChangeCell ("Pesho beshe tuk") obj_sav.AddChangeCell ("Gosho beshe tuk") obj_sav.AddChangeCell ("Atanas beshe tuk") obj_sav.AddChangeCell ("I az byah tuk") specs.It("A099").Expect(obj_sav.ChangeCell(1)).ToEqual "Pesho beshe tuk" specs.It("A100").Expect(obj_sav.ChangeCell(2)).ToEqual "Gosho beshe tuk" specs.It("A101").Expect(obj_sav.ChangeCell(3)).ToEqual "Atanas beshe tuk" specs.It("A102").Expect(obj_sav.ChangeCell(3)).ToNotEqual "Gosho beshe tuk" specs.It("A103").Expect(obj_sav.ChangesTotal).ToEqual 4 specs.It("A104").Expect(obj_sav.ChangesTotal).ToNotEqual 5 obj_sav.AddChangeCell ("I az byah tuk2") specs.It("A105").Expect(obj_sav.ChangesTotal).ToEqual 5 specs.It("A106").Expect(obj_sav.Changes).ToEqual "vit" & vbCrLf & "osh" obj_sav.EraseChanges specs.It("A107").Expect(obj_sav.Changes).ToEqual "" obj_sav.Changes = "vi" obj_sav.Changes = "to" specs.It("A108").Expect(obj_sav.Changes).ToEqual "vi" & vbCrLf & "to" specs.It("A109").Expect(obj_con.FORMULA_CALCULATIONS(10, 5, 3, True)).ToEqual "=RC[-1]+(((RC6-RC10)*0.9)/5)" specs.It("A110").Expect(obj_con.FORMULA_CALCULATIONS(10, 5, 3)).ToEqual "=RC[-1]+((RC6-RC10)/5)" specs.It("A111").Expect(obj_con.FORMULA_CALCULATIONS(10, 5, 0, True)).ToEqual "=RC[-1]+(RC6*0.9/5)" specs.It("A112").Expect(obj_con.FORMULA_CALCULATIONS(10, 5, 0)).ToEqual "=RC[-1]+(RC6/5)" obj_input_dates.AddRate1_Date ("01.01.2013") obj_input_dates.AddRate1_Date ("02.01.2013") obj_input_dates.AddRate1_Date ("03.01.2013") specs.It("A113").Expect(obj_input_dates.rate1_date(3)).ToEqual CDate("03.01.2013") specs.It("A114").Expect(obj_input_dates.rate1_date(1)).ToNotEqual CDate("02.01.2013") specs.It("A115").Expect(obj_input_dates.rate1_date(2)).ToEqual CDate("02.01.2013") obj_input_dates.AddRate2_Date ("01.01.2011") obj_input_dates.AddRate2_Date ("01.01.2012") obj_input_dates.AddRate2_Date ("01.01.2013") obj_input_dates.AddRate2_Date ("01.01.2014") obj_input_dates.AddRate2_Date ("01.01.2015") obj_input_dates.AddRate2_Date ("01.01.2016") specs.It("A116").Expect(obj_input_dates.rate2_date(1)).ToEqual CDate("01.01.2011") specs.It("A117").Expect(obj_input_dates.rate2_date(4)).ToEqual CDate("01.01.2014") specs.It("A118").Expect(obj_input_dates.rate2_date(5)).ToNotEqual CDate("01.01.2014") obj_input_dates.AddRate6_Date ("01.01.2020") obj_input_dates.AddRate6_Date ("01.01.2021") obj_input_dates.AddRate6_Date ("01.01.2022") specs.It("A119").Expect(obj_input_dates.rate6_date(3)).ToEqual CDate("01.01.2022") specs.It("A120").Expect(obj_input_dates.rate6_date(1)).ToEqual CDate("01.01.2020") specs.It("A121").Expect(obj_input_dates.rate6_date(2)).ToNotEqual CDate("01.01.2020") obj_input_dates.AddRate7_Date ("01.01.2013") obj_input_dates.AddRate7_Date ("02.01.2013") obj_input_dates.AddRate7_Date ("03.01.2013") obj_input_dates.AddRate7_Date ("04.01.2013") obj_input_dates.AddRate7_Date ("05.01.2013") obj_input_dates.AddRate7_Date ("06.01.2013") specs.It("A122").Expect(obj_input_dates.rate7_date(6)).ToEqual CDate("06.01.2013") specs.It("A123").Expect(obj_input_dates.rate7_date(5)).ToEqual CDate("05.01.2013") specs.It("A124").Expect(obj_input_dates.rate7_date(6)).ToEqual CDate("06.01.2013") specs.It("A125").Expect(obj_input_dates.rate7_date(5)).ToEqual CDate("05.01.2013") specs.It("A126").Expect(obj_input_dates.rate7_date(1)).ToEqual CDate("01.01.2013") specs.It("A127").Expect(obj_input_dates.rate7_date(2)).ToNotEqual CDate("01.01.2013") obj_input_dates.Ankaufsdatum = CDate("07.08.2011") specs.It("A128").Expect(obj_input_dates.Ankaufsdatum).ToEqual CDate("07.08.2011") obj_input_dates.Ankaufsdatum = CDate("07.08.2012") specs.It("A129").Expect(obj_input_dates.Ankaufsdatum).ToEqual CDate("07.08.2012") specs.It("A130").Expect(obj_input_dates.Ankaufsdatum).ToNotEqual CDate("07.08.2013") obj_input_dates.Ankaufsdatum = CDate("07.08.2013") specs.It("A131").Expect(obj_input_dates.Ankaufsdatum).ToEqual CDate("07.08.2013") obj_input_dates.Baueingabe = CDate("07.08.2021") specs.It("A132").Expect(obj_input_dates.Baueingabe).ToEqual CDate("07.08.2021") obj_input_dates.Baueingabe = CDate("07.08.2022") specs.It("A133").Expect(obj_input_dates.Baueingabe).ToEqual CDate("07.08.2022") obj_input_dates.Baueingabe = CDate("07.08.2023") specs.It("A134").Expect(obj_input_dates.Baueingabe).ToNotEqual CDate("07.08.2022") obj_input_dates.Baugenehmigung = CDate("01.08.2011") specs.It("A135").Expect(obj_input_dates.Baugenehmigung).ToEqual CDate("01.08.2011") obj_input_dates.Baugenehmigung = CDate("02.08.2012") specs.It("A136").Expect(obj_input_dates.Baugenehmigung).ToEqual CDate("02.08.2012") obj_input_dates.Baugenehmigung = CDate("03.08.2013") specs.It("A137").Expect(obj_input_dates.Baugenehmigung).ToEqual CDate("03.08.2013") specs.It("A138").Expect(obj_input_dates.Baugenehmigung).ToNotEqual CDate("02.08.2013") str_initial = tbl_main.cmb_land tbl_main.cmb_land = [set_nameGermany] specs.It("A139").Expect([set_vat_used].Text).ToEqual ([set_vatGermany].Text) specs.It("A140").Expect(obj_test_land.str_get_land).ToEqual ([set_nameGermany].Text) specs.It("A141").Expect(obj_test_land.str_get_short_name).ToEqual ([set_shortNameGermany].Text) specs.It("A142").Expect(obj_test_land.str_get_short_name).ToNotEqual ([set_shortNameAustria].Text) tbl_main.cmb_land = [set_nameAustria] specs.It("A143").Expect([set_vat_used].Text).ToEqual ([set_vatAustria].Text) specs.It("A144").Expect(obj_test_land.str_get_land).ToEqual ([set_nameAustria].Text) specs.It("A145").Expect(obj_test_land.str_get_short_name).ToEqual ([set_shortNameAustria].Text) specs.It("A146").Expect(obj_test_land.str_get_short_name).ToNotEqual ([set_shortNameGermany].Text) tbl_main.cmb_land = [set_nameGermany] InlineRunner.RunSuite specs Call specs.TotalTests Call OnEnd Set specs = Nothing Set obj_calendar = Nothing Set obj_con = Nothing Set obj_dat = Nothing Set obj_sav = Nothing Set obj_input_dates = Nothing Set obj_test_land = Nothing On Error GoTo 0 End Sub Public Sub CreateNumbers(Optional l_size_cols As Long = 10, _ Optional l_size_total As Long = 1000) Dim l_counter As Long Dim l_row As Long Dim l_col As Long ActiveSheet.Cells.Clear For l_counter = 0 To l_size_total - 1 l_row = l_counter \ l_size_cols l_col = l_counter Mod l_size_cols ActiveSheet.[a1].Offset(l_row, l_col) = l_counter + 1 Next l_counter End Sub ================================================ FILE: __Arch/UseEnvironName.vb ================================================ Public Sub SetWorkedBy() Set my_cell = tbl_plan.Cells(obj_plan.LastLine, obj_cal.RightColPosition) my_cell = "WorkedBy: " & Application.WorksheetFunction.Proper(Environ("username")) & " - " & Format(Now(), "Short Date") my_cell.HorizontalAlignment = xlRight End Sub ================================================ FILE: __Arch/Userful_Application.vb ================================================ ?application.PathSeparator ?application.DecimalSeparator ?Application.International(xlFormula) ================================================ FILE: __Arch/XL_password_cracker.vb ================================================ 'https://stackoverflow.com/questions/11649064/excel-spreadsheet-password-cracking-using-vba Sub PasswordBreaker() 'Breaks worksheet password protection. Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox "One usable password is " & Chr(i) & Chr(j) & _ Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Sub ================================================ FILE: __Arch/addPictureToFile.vb ================================================ Private Sub opt_de_Click() 'Make a userForm to keep the pictures there! img_flag.Picture = user_form_pics.flag_de.Picture opt_stadt1 = True opt_stadt2.Visible = True opt_stadt3.Visible = True opt_stadt4.Visible = True opt_stadt5.Visible = True opt_stadt1.Caption = [set_muc_name] opt_stadt2.Caption = [set_han_name] opt_stadt3.Caption = [set_bln_name] opt_stadt4.Caption = [set_nbg_name] opt_stadt5.Caption = [set_ffm_name] Call opt_stadt1_Click FixInputSheet End Sub ================================================ FILE: __Arch/all_of_a_kind.vb ================================================ Public Sub remove_space_in_string() Dim r_range As Range For Each r_range In Selection r_range = Trim(r_range) r_range = Replace(r_range, vbTab, "") r_range = Replace(r_range, " ", "") r_range = Replace(r_range, Chr(160), "") Next r_range End Sub Public Sub FreezeTopRow() Dim ws As Worksheet Application.ScreenUpdating = False Set ws = Worksheets("calendar") Application.Goto ws.Range("h2") ActiveWindow.FreezePanes = True Set ws = Nothing End Sub Public Sub OnStart() Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False End Sub Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False End Sub Public Sub pls(Optional b_unhide As Boolean = False) If b_value_in_array(Environ("username"), S_ADMINS, True) Then tbl_main.Unprotect Password:=s_co If b_unhide Then Call UnhideAll Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" Debug.Print "ok :)" Else MsgBox Environ("username") & " you are not allowed to do this. Speak with Vitosh.", vbInformation, [set_planerkostenberechnung] End If End Sub Public Sub LockMe() tbl_main.Protect Password:=s_co Debug.Print "locked" End Sub Public Sub HideNeeded() Dim var_Sheet As Variant Dim arr_visible_sheets As Variant Dim arr_hidden_sheets As Variant Call OnStart arr_visible_sheets = Array(tbl_main, tbl_calendar) arr_hidden_sheets = Array(tbl_hon_aus, tbl_hon_geb, tbl_hon_hlse, tbl_hon_tra, tbl_hono_bs, tbl_hono_ps, tbl_public, tbl_settings) For Each var_Sheet In arr_visible_sheets var_Sheet.Visible = xlSheetVisible Next var_Sheet For Each var_Sheet In arr_hidden_sheets var_Sheet.Visible = xlSheetVeryHidden Next var_Sheet Call OnEnd End Sub Public Sub UnhideAll() Dim Sheet As Worksheet For Each Sheet In ThisWorkbook.Worksheets ' If Sheet.Visible = Not xlSheetVisible Then Sheet.Visible = xlSheetVisible Sheet.Visible = xlSheetVisible Next Sheet End Sub Public Function calculate_range(from_row As Long, to_row As Long, l_column As Long, _ Optional s_sheet_name As String = "calendar") As Double Dim ws As Worksheet Dim l_counter As Long Dim d_result As Double Set ws = ThisWorkbook.Worksheets(s_sheet_name) For l_counter = from_row To to_row Call Increment(d_result, ws.Cells(l_counter, l_column)) Next l_counter Set ws = Nothing calculate_range = Round(d_result, 2) End Function Public Sub FixOutlook() tbl_calendar.Cells.EntireColumn.AutoFit End Sub Public Sub HideRange(r_range_to_hide As Range) Dim my_cell As Range Dim l_ba_value As Long l_ba_value = tbl_main.cmb_ba.value + r_range_to_hide.Row - 1 For Each my_cell In r_range_to_hide If my_cell.Row > l_ba_value Then my_cell.Interior.Pattern = xlGray8 my_cell.Font.ThemeColor = xlThemeColorDark1 Else my_cell.Interior.Pattern = xlAutomatic my_cell.Font.ColorIndex = xlAutomatic End If Next my_cell r_range_to_hide.Borders(xlEdgeTop).LineStyle = xlContinuous r_range_to_hide.Borders(xlEdgeLeft).LineStyle = xlContinuous r_range_to_hide.Borders(xlEdgeBottom).LineStyle = xlContinuous r_range_to_hide.Borders(xlEdgeRight).LineStyle = xlContinuous End Sub Public Function add_months(ByVal my_date As Date, ByVal i_month As Integer, Optional ByVal b_use_last_date = False) As Date If b_use_last_date Then add_months = get_last_day_of_month(DateAdd("m", i_month, my_date)) Else add_months = DateAdd("m", i_month, my_date) End If End Function Public Function get_last_day_of_month(my_date As Date) As Date get_last_day_of_month = DateSerial(Year(my_date), Month(my_date) + 1, 0) End Function Public Sub AddSomething(str_to_add As String, Optional c_range As Variant) Dim my_cell As Range If IsMissing(c_range) Then Set c_range = Selection For Each my_cell In c_range my_cell = my_cell & str_to_add Next my_cell Set c_range = Nothing End Sub Public Sub Meter2() Selection.NumberFormat = "0"" m" & Chr(179) & """" End Sub Public Function change_commas(ByVal myValue As Variant) As String Dim str_temp As String str_temp = CStr(myValue) change_commas = Replace(str_temp, ",", ".") End Function Public Sub Increment(ByRef value_to_increment, Optional l_plus As Double = 1) 'optional value type changed to double value_to_increment = value_to_increment + l_plus End Sub Public Sub DeleteName(sName As String) On Error GoTo DeleteName_Error ActiveWorkbook.Names(sName).Delete Debug.Print sName & " is deleted!" On Error GoTo 0 Exit Sub DeleteName_Error: Debug.Print sName & " not present or some error" On Error GoTo 0 End Sub Public Function RGB2HTMLColor(B As Byte, G As Byte, r As Byte) As String Dim HexR As Variant, HexB As Variant, HexG As Variant Dim sTemp As String On Error GoTo ErrorHandler 'R HexR = Hex(r) If Len(HexR) < 2 Then HexR = "0" & HexR 'Get Green Hex HexG = Hex(G) If Len(HexG) < 2 Then HexG = "0" & HexG HexB = Hex(B) If Len(HexB) < 2 Then HexB = "0" & HexB RGB2HTMLColor = HexR & HexG & HexB Debug.Print "Red and Blue are reversed ... pay attention to the input in the input" Exit Function ErrorHandler: Debug.Print "RGB2HTMLColor was not successful" End Function Public Function sum_array(my_array As Variant, Optional last_values_not_to_calculate As Long = 0) As Double Dim l_counter As Long For l_counter = LBound(my_array) To UBound(my_array) - last_values_not_to_calculate sum_array = sum_array + my_array(l_counter) Next l_counter End Function Public Function b_value_in_array(my_value As Variant, _ my_array As Variant, _ Optional b_is_string As Boolean = False, _ Optional str_separator As String = ":") As Boolean Dim l_counter If b_is_string Then my_array = Split(my_array, str_separator) End If For l_counter = LBound(my_array) To UBound(my_array) my_array(l_counter) = CStr(my_array(l_counter)) Next l_counter b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0)) End Function Public Sub HideSelectedSheets() ActiveWindow.SelectedSheets.Visible = False End Sub '--------------------------------------------------------------------------------------- ' Method : MinimizeRibbon ' Author : v.doynov ' Date : 29.09.2016 ' Purpose: Minimizes the ribbon, if b_minimize is TRUE, maximizes if FALSE. '--------------------------------------------------------------------------------------- Public Sub MinimizeRibbon(Optional b_minimize = True) On Error GoTo MinimizeRibbon_Error If (Not CommandBars.GetPressedMso("MinimizeRibbon")) And b_minimize Then CommandBars.ExecuteMso "MinimizeRibbon" End If If (CommandBars.GetPressedMso("MinimizeRibbon")) And (Not b_minimize) Then CommandBars.ExecuteMso "MinimizeRibbon" End If On Error GoTo 0 Exit Sub MinimizeRibbon_Error: Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure MinimizeRibbon of Sub mod_sheets" End Sub ================================================ FILE: __Arch/browse.vb ================================================ Private Sub cmd_browse_Click() Dim str_file As String str_file = Application.GetOpenFilename _ (Title:="Please choose a file to open", _ FileFilter:="Excel Files *.xls* (*.xls*),") txtbox_display.Text = str_file End Sub ================================================ FILE: __Arch/btn_open_Click.vb ================================================ 'Opens the file open file open a file open a folder open folder 'Eliminates the file name and opens the folder. Private Sub btn_open_Click() On Error GoTo btn_open_Click_Error Dim my_str As String Dim my_str2 As String my_str = tbl_input.lblDisplayTerminPlanner my_str2 = Left(my_str, Len(my_str) - Len(Split(my_str, "\")(UBound(Split(my_str, "\"))))) Call Shell("explorer.exe" & " " & my_str2, vbNormalFocus) btn_open_Click_Error: Debug.Print "Error " & Err.Number & " (" & Err.Description & ")" End Sub ================================================ FILE: __Arch/bus.vb ================================================ Public Function WriteString(ByVal n As Long) As String 'Lucida Console or Consolas Dim v_Bus() As Variant Dim s_char As String Dim i As Long Dim l_col As Long Dim l_row As Long n = n - 1 v_Bus = Array("+------------------------+", _ "|......................|D|)", _ "|......................|.|", _ "|........................|", _ "|......................|.|)", _ "+------------------------+") For i = 0 To 33 If i > n Then s_char = "#" Else s_char = "O" End If If i < 4 Then l_col = 0 ElseIf i = 4 Then l_col = 1 Else l_col = (i - 2) / 3 End If If i <= 3 Then l_row = i Else l_row = (i - 4) Mod 3 End If If (l_row = 2 And l_col <> 0) Then l_row = l_row + 1 Mid(v_Bus(l_row + 1), (1 + l_col * 2) + 1, 1) = s_char Next i WriteString = draw_bus(v_Bus) End Function Public Function draw_bus(v_Bus As Variant) As String Dim i As Long For i = LBound(v_Bus) To UBound(v_Bus) draw_bus = draw_bus & v_Bus(i) & vbCrLf Next i End Function Public Sub TestBus() Dim l_counter As Long For l_counter = 1 To 34 Debug.Print l_counter Debug.Print WriteString(l_counter) Next l_counter End Sub ================================================ FILE: __Arch/call_click_event_from_module.vb ================================================ Sub maina() Run "tbl_Input.btn_main_Click" End Sub ================================================ FILE: __Arch/cls_counter.vb ================================================ Sub TDD() Dim specs As New SpecSuite Dim test_calendar As New cls_calendar Dim test_plan As New cls_plan Dim test_counter As New cls_counter test_calendar.IncrementRow specs.It("cls_c1").Expect(test_calendar.CurrentRow).ToEqual 1 test_calendar.IncrementRow test_calendar.CurrentRow = 5 test_calendar.IncrementRow specs.It("cls_c2").Expect(test_calendar.CurrentRow).ToEqual 6 test_calendar.LeftDate = "01.09.2015" test_calendar.RightDate = "01.08.2021" specs.It("cls_c3").Expect(test_calendar.Duration).ToEqual 71 test_plan.LastLines_Row = 30 test_plan.LastLines_Row = 31 test_plan.LastLines_Row = 1000 specs.It("plan_c4").Expect(test_plan.LastLines_Row(1)).ToEqual 30 specs.It("plan_c5").Expect(test_plan.LastLines_Row(2)).ToEqual 31 specs.It("plan_c6").Expect(test_plan.LastLines_Row(3)).ToEqual 1000 specs.It("plan_c7").Expect(test_plan.LastLines_Row_Count).ToEqual 3 specs.It("plan_c8").Expect(test_plan.LastLines_Row_Count).ToNotEqual 4 test_counter.IncrementCounter test_counter.IncrementCounter specs.It("counter_c9").Expect(test_counter.Counter).ToEqual 2 specs.It("counter_c10").Expect(test_counter.Counter).ToNotEqual 3 test_counter.ResetCounter specs.It("counter_c11").Expect(test_counter.Counter).ToEqual 0 test_counter.IncrementCounter (10) specs.It("counter_c12").Expect(test_counter.Counter).ToEqual 10 test_counter.IncrementCounter specs.It("counter_c12a").Expect(test_counter.Counter).ToEqual 11 test_counter.DecrementCounter specs.It("counter_c12b").Expect(test_counter.Counter).ToEqual 10 test_counter.ResetCounter test_counter.DecrementCounter specs.It("counter_c12c").Expect(test_counter.Counter).ToEqual -1 test_counter.ResetCounter test_counter.IncrementCounter test_counter.Flag specs.It("counter_c13").Expect(test_counter.IsFlagged).ToEqual True test_counter.IncrementCounter specs.It("counter_c14").Expect(test_counter.IsFlagged).ToEqual False test_counter.Flag specs.It("counter_c15").Expect(test_counter.IsFlagged).ToEqual True test_counter.UnFlag specs.It("counter_c16").Expect(test_counter.IsFlagged).ToEqual False InlineRunner.RunSuite specs Set test_calendar = Nothing Set test_plan = Nothing Set specs = Nothing Set test_counter = Nothing End Sub 'Unit tests are here: Sub TDD() Dim specs As New SpecSuite Dim test_calendar As New cls_calendar Dim test_plan As New cls_plan Dim test_counter As New cls_counter test_counter.IncrementCounter test_counter.IncrementCounter specs.It("counter_c9").Expect(test_counter.Counter).ToEqual 2 specs.It("counter_c10").Expect(test_counter.Counter).ToNotEqual 3 test_counter.ResetCounter specs.It("counter_c11").Expect(test_counter.Counter).ToEqual 1 test_counter.IncrementCounter (10) specs.It("counter_c12").Expect(test_counter.Counter).ToEqual 11 test_counter.ResetCounter test_counter.IncrementCounter test_counter.Flag specs.It("counter_c13").Expect(test_counter.IsFlagged).ToEqual True test_counter.IncrementCounter specs.It("counter_c14").Expect(test_counter.IsFlagged).ToEqual False test_counter.Flag specs.It("counter_c14").Expect(test_counter.IsFlagged).ToEqual True test_counter.UnFlag specs.It("counter_c14").Expect(test_counter.IsFlagged).ToEqual False InlineRunner.RunSuite specs Set test_calendar = Nothing Set test_plan = Nothing Set specs = Nothing Set test_counter = Nothing End Sub ================================================ FILE: __Arch/code_making_code.vb ================================================ Public Sub TakeValues() Dim my_cell As Range Dim str As String Dim l_counter As Long For Each my_cell In Selection Call Increment(l_counter) str = "my_arr(" & l_counter & ")= " If Len(my_cell) > 1 Then str = str & change_commas(my_cell.value) Else str = str & 0 End If Debug.Print str Next my_cell End Sub ================================================ FILE: __Arch/colors.vb ================================================ Const p_COLOR_YELLOW = 65535 Const p_COLOR_BLUE = 14470546 Const p_COLOR_BLUE_NEGATIVE = 16770927 Const p_COLOR_BLUE_ZERO = 14136213 Const p_COLOR_WHITE = -4142 '16777215 ================================================ FILE: __Arch/copy_newsheet_new sheet.vb ================================================ Option Explicit Private Sub Workbook_NewSheet(ByVal Sh As Object) On Error GoTo Workbook_NewSheet_Error Sheets(1).Rows("1:2").Copy Sh.Paste Application.CutCopyMode = False 'Sheets(1).Columns(1).Copy Sheets(1).Columns("A:D").Copy Sh.Paste Application.CutCopyMode = False Sh.Cells(1, 1).Select On Error GoTo 0 Exit Sub Workbook_NewSheet_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_NewSheet of VBA Document DieseArbeitsmappe" End Sub ================================================ FILE: __Arch/delete_row.vb ================================================ Option Explicit 'call CheckAndDelete(Range("A1:A10"),1,"1") Public Sub CheckAndDelete(r_range As Range, l_column As Long, Optional s_char As String = ".") Dim l_counter As Long Dim r_cell As Range For l_counter = r_range.Cells(r_range.Count).Row To r_range.Cells(1, 1).Row Step -1 Set r_cell = Cells(l_counter, l_column) If InStr(1, r_cell, s_char, vbTextCompare) Then Rows(l_counter).EntireRow.Delete End If Next l_counter Set r_cell = Nothing Set r_range = Nothing End Sub ================================================ FILE: __Arch/errors.vb ================================================ 'Err.Raise 1985, "NAME", "NAME THE CUSTOM ERRROR" 'http://onlinelibrary.wiley.com/doi/10.1002/9781118257616.app3/pdf Main2_Error: If Err.Number = [set_standard_error_number] Then MsgBox Err.Description & vbCrLf & "Fehler bei Modul " & Err.Source, vbInformation, [set_awaited_error] Else MsgBox "Error " & Err.Number & " (" & Err.Description & ")", vbInformation, [set_awaited_error_not] End If End Sub ================================================ FILE: __Arch/example.hta.htm ================================================ Simple Strange Calculator for VitoshAcademy.Com
================================================ FILE: __Arch/form_VBA.vb ================================================ Private Sub UserForm_Activate() img_sad.Visible = False img_smile.Visible = True With frm_green .Top = Application.Top + 200 .Left = Application.Left + 100 End With If b_is_error Then frm_green.lbl_status.BackColor = RGB(200, 10, 10) frm_green.lbl_status = [set_paku_thankyou] & vbCrLf & "Status: Nicht erfolgreich! :(" img_sad.Visible = True img_smile.Visible = False Me.Repaint Application.Wait (Now + TimeValue("00:00:01")) Else frm_green.lbl_status.BackColor = RGB(10, 200, 10) frm_green.lbl_status = [set_paku_thankyou] & vbCrLf & "Status: Erfolgreich! :) " End If Me.Repaint Application.Wait (Now + TimeValue("00:00:02")) Unload Me End Sub ================================================ FILE: __Arch/general_smalls.vb ================================================ Option Explicit Sub FixRangeError() 'Fix bezug fehler Dim r_range As Range Dim str_text As String Dim l_counter As Long Dim str_result As String Dim arr_result As Variant Dim arr_range As Variant ReDim arr_result(0) Set r_range = Selection str_text = Replace(r_range.Formula, "=", "") arr_range = Split(str_text, "+") For l_counter = LBound(arr_range) To UBound(arr_range) If Not InStr(arr_range(l_counter), "#") > 0 Then ReDim Preserve arr_result(UBound(arr_result) + 1) arr_result(UBound(arr_result)) = arr_range(l_counter) End If Next l_counter For l_counter = LBound(arr_result) + 1 To UBound(arr_result) str_result = str_result & "+" & arr_result(l_counter) Next l_counter Debug.Print str_result End Sub ================================================ FILE: __Arch/hide_selected_sheets.vb ================================================ Public Sub HideSelectedSheets() ActiveWindow.SelectedSheets.Visible = False End Sub ================================================ FILE: __Arch/info.txt ================================================ Images for the ribbon: http://soltechs.net/customui/imagemso01.asp ================================================ FILE: __Arch/isUserFormLoaded.vb ================================================ used this way: If IsUserFormLoaded("frmPlanerkostenberechnung") Then Unload frmPlanerkostenberechnung Function IsUserFormLoaded(ByVal UFName As String) As Boolean Dim UForm As Object For Each UForm In VBA.UserForms If UForm.Name = UFName Then IsUserFormLoaded = True Exit Function End If Next End Function ================================================ FILE: __Arch/languages.vb ================================================ 'change language 'change fonts Option Explicit Public Enum LandName BG US DE End Enum Private Const LOCALE_ILANGUAGE As Long = &H1 Private Const LOCALE_SCOUNTRY As Long = &H6 Private Declare Function ActivateKeyboardLayout Lib "user32.dll" (ByVal myLanguage As Long, Flag As Boolean) As Long Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long Declare Function getUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, ByRef nSize As Long) As Long Private Declare Function GetLocaleInfo Lib "kernel32" _ Alias "GetLocaleInfoA" _ (ByVal Locale As Long, _ ByVal LCType As Long, _ ByVal lpLCData As String, _ ByVal cchData As Long) As Long Public Function f_str_country_name(l_landname As Long) As String Dim str_result As String Select Case l_landname Case 0: str_result = "Bulgarien" Case 1: str_result = "Vereinigte Staaten" Case 2: str_result = "Deutschland" End Select f_str_country_name = str_result End Function Public Function f_lng_country_code(l_landname As Long) As Long Dim lng_result As Long Select Case l_landname Case 0: lng_result = 1026 Case 1: lng_result = 1033 Case 2: lng_result = 1031 End Select f_lng_country_code = lng_result End Function Public Sub ChangeLanguages() Call SetLanguage(f_str_country_name(LandName.DE), f_lng_country_code(LandName.DE)) Call SetLanguage(f_str_country_name(LandName.BG), f_lng_country_code(LandName.BG)) Call SetLanguage(f_str_country_name(LandName.US), f_lng_country_code(LandName.US)) Call SetLanguage End Sub Public Sub SetLanguage(Optional str_lang As String = "Bulgarien", Optional l_code As Long = 1026) If Not f_str_get_language = str_lang Then ActivateKeyboardLayout l_code, 0 End If End Sub Public Function f_str_get_language() Dim hKeyboardID As Long Dim LCID As Long hKeyboardID = GetKeyboardLayout(0&) LCID = LoWord(hKeyboardID) f_str_get_language = GetUserLocaleInfo(LCID, LOCALE_SCOUNTRY) End Function Private Function LoWord(wParam As Long) As Long If wParam And &H8000& Then LoWord = &H8000& Or (wParam And &H7FFF&) Else LoWord = wParam And &HFFFF& End If End Function Public Function GetUserLocaleInfo(ByVal dwLocaleID As Long, ByVal dwLCType As Long) As String Dim sReturn As String Dim nSize As Long nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn)) If nSize > 0 Then sReturn = Space$(nSize) nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn)) If nSize > 0 Then GetUserLocaleInfo = Left$(sReturn, nSize - 1) End If End If End Function ================================================ FILE: __Arch/last_row_of_named_range.vb ================================================ '[hon_br_kosten].rows.count-1+[hon_br_kosten].row 'last row of named range Public Function get_last_row_of_named_range(my_range As Range) As Long get_last_row_of_named_range = my_range.Rows.Count - 1 + my_range.Row End Function ================================================ FILE: __Arch/mod_cumulative_sum.vb ================================================ Option Explicit Public Function return_line(my_range As Range, percentage As Double) As Integer Dim my_cell As Range Dim my_result As Double For Each my_cell In my_range my_result = my_result + my_cell.Value If my_result >= (Application.WorksheetFunction.Sum(my_range) * percentage) Then return_line = my_cell.Row - my_range.Row + 1 Exit For End If Next my_cell End Function Public Function change_commas(ByVal myValue As Variant) As String Dim str_temp As String str_temp = CStr(myValue) change_commas = Replace(str_temp, ",", ".") End Function Public Sub FormatAsDate(ByRef cell As Range) cell.NumberFormat = "[$-407]mmm/ yy;@" End Sub Public Sub FormatAsPercent(ByRef my_cell As Range) my_cell.Style = "Percent" my_cell.NumberFormat = "0.00%" End Sub Public Sub FormatAsCurrency(ByRef cell As Range, Optional ByVal b_change_0 = False) If IsNumeric(cell.Value) And Not cell.HasFormula Then cell.Value = Round(cell.Value, 2) End If cell.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" If b_change_0 Then With cell .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=0" .FormatConditions(1).Font.ThemeColor = xlThemeColorDark1 .FormatConditions(1).Font.TintAndShade = -0.25 End With End If End Sub Public Function millions_eur(ByVal my_value As Long) As Long millions_eur = my_value / 1000000 End Function Public Sub WhiteYourself(ByVal lines As Long, ByRef my_sheet As Worksheet) Dim str_lines As String str_lines = lines & ":" & lines With my_sheet.Rows(str_lines).Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End Sub Public Sub FormatFontColorToGrey(ByRef cell As Range) cell.Font.Color = RGB(128, 128, 128) End Sub Public Sub UnprotectAll() Dim i As Integer For i = ActiveWorkbook.Worksheets.Count To 1 Step -1 ActiveWorkbook.Worksheets(i).Unprotect Password:=SECRET_PASSWORD Next End Sub Public Sub ProtectAll() Dim i As Integer For i = ActiveWorkbook.Worksheets.Count To 1 Step -1 ActiveWorkbook.Worksheets(i).Activate ActiveWorkbook.Worksheets(i).Cells(1, 1).Select ActiveWorkbook.Worksheets(i).Protect Password:=SECRET_PASSWORD Next End Sub Public Function distribution_term_calculation(total_term) As Long If total_term >= 6 Then distribution_term_calculation = 6 ElseIf total_term < 6 And total_term >= 2 Then distribution_term_calculation = 2 Else distribution_term_calculation = 1 End If End Function Public Function sum_range(my_range As Range) As Double Dim cell As Range sum_range = 0 For Each cell In my_range sum_range = sum_range + cell.Value Next End Function Public Function make_random(down As Long, up As Long) As Long make_random = CLng((up - down + 1) * Rnd + down) If make_random > up Then make_random = up If make_random < down Then make_random = down End Function Public Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row End Function ================================================ FILE: __Arch/mod_environ.vb ================================================ Option Explicit Declare Function GetLocaleInfo Lib "kernel32" Alias _ "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, _ ByVal lpLCData As String, ByVal cchData As Long) As Long Declare Function GetUserDefaultLCID% Lib "kernel32" () Public Const LOCALE_SLIST = &HC Public Function GetListSeparator() As String '?environ("pathext") Dim ListSeparator As String Dim iRetVal1 As Long Dim iRetVal2 As Long Dim lpLCDataVar As String Dim Position As Integer Dim Locale As Long Locale = GetUserDefaultLCID() iRetVal1 = GetLocaleInfo(Locale, LOCALE_SLIST, lpLCDataVar, 0) ListSeparator = String$(iRetVal1, 0) iRetVal2 = GetLocaleInfo(Locale, LOCALE_SLIST, ListSeparator, iRetVal1) Position = InStr(ListSeparator, Chr$(0)) If Position > 0 Then GetListSeparator = Left$(ListSeparator, Position - 1) End If End Function Sub EnumSEVars() Dim strVar As String Dim i As Long For i = 1 To 255 strVar = Environ$(i) If LenB(strVar) = 0& Then Exit For Debug.Print strVar Next End Sub ================================================ FILE: __Arch/mod_excel_functions.vb ================================================ Option Explicit Public Function return_line(my_range As Range, percentage As Double) As Integer Dim my_cell As Range Dim my_result As Double For Each my_cell In my_range my_result = my_result + my_cell.Value If my_result >= (Application.WorksheetFunction.Sum(my_range) * percentage) Then return_line = my_cell.Row - my_range.Row + 1 Exit For End If Next my_cell End Function ================================================ FILE: __Arch/mod_from_experience_various.vb ================================================ Public Sub ColorTheColumn() Dim l_counter As Long Dim my_cell As Range Dim my_cell_find As Range For l_counter = 1 To l_writing_row Set my_cell = tbl_output.Cells(l_counter, 1) Set my_cell_find = tbl_settings.Range("CN:CN").Find(my_cell, LookIn:=xlValues) If Not my_cell_find Is Nothing Then If my_cell_find.Offset(0, 1) = "bold" Then my_cell.Font.Bold = True End If If my_cell_find.Offset(0, 2) = "red" Then my_cell.Font.Color = -16777063 End If End If Next l_counter End Sub Public Sub PrintPage() Dim Sh As Worksheet Dim rngPrint As Range Dim s_reduce_paper_title As String On Error GoTo PrintPage_Error s_reduce_paper_title = "Reduzieren Sie den Papierverbrauch" Set Sh = ActiveSheet Set rngPrint = [input_print_area] With Sh.PageSetup .Orientation = xlPortrait .Zoom = False .FitToPagesTall = 1 .FitToPagesWide = 1 End With Select Case MsgBox("Sind Sie sicher, dass Sie drucken moechten?", vbYesNo Or vbQuestion Or vbDefaultButton1, s_reduce_paper_title) Case vbYes Select Case MsgBox("Wirklich sicher, dass Sie drucken moechten?", vbYesNo Or vbQuestion Or vbDefaultButton1, s_reduce_paper_title) Case vbYes rngPrint.PrintOut End Select End Select On Error GoTo 0 Exit Sub PrintPage_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PrintPage of Modul mod_Drucken" End Sub Public Sub print_array(my_array As Variant) Dim counter As Integer For counter = LBound(my_array) To UBound(my_array) Debug.Print counter & " --> " & my_array(counter) Next counter End Sub Public Sub GenerateSumsOutput(l_lower_row As Long, l_higher_row As Long, l_current_row As Long) Dim r_cell As Range Dim l_counter As Long For l_counter = arr_calendar_settings(2) To arr_calendar_settings(3) Set r_cell = tbl_output.Cells(l_current_row, l_counter) r_cell.FormulaR1C1 = "=SUM(R" & l_higher_row & "C:R" & l_lower_row & "C)" Next l_counter Set r_cell = Nothing End Sub Public Sub swap_variables(ByRef value_1, ByRef value_2) Dim int_tmp As Integer int_tmp = value_1 value_1 = value_2 value_2 = int_tmp End Sub Public Function calculate_years_from_months(total_term) As Long calculate_years_from_months = total_term \ MONTHS_IN_YEAR If total_term Mod MONTHS_IN_YEAR Then calculate_years_from_months = calculate_years_from_months + 1 End Function Public Function letter_col(ByVal col As Long) As String letter_col = Split(Cells(1, col).Address, "$")(1) End Function Public Function bool_zero_or_empty(ByRef cell As Range, Optional b_is_range = False) As Boolean If b_is_range Then For Each current_cell In cell If (IsEmpty(current_cell) Or current_cell.Value = 0) Then bool_zero_or_empty = True Exit Function Else bool_zero_or_empty = False End If Next current_cell Else If (IsEmpty(cell) Or cell.Value = 0) Then bool_zero_or_empty = True Else bool_zero_or_empty = False End If End If End Function Public Function change_commas(ByVal myValue As Variant) As String Dim str_temp As String str_temp = CStr(myValue) change_commas = Replace(str_temp, ",", ".") End Function Public Sub FormatAsDate(ByRef cell As Range) cell.NumberFormat = "[$-407]mmm/ yy;@" End Sub Public Sub FormatAsPercent(ByRef my_cell As Range) my_cell.Style = "Percent" my_cell.NumberFormat = "0.00%" End Sub Public Sub FormatAsCurrency(ByRef cell As Range, Optional ByVal b_change_0 = False, Optional b_make_gray = True) Dim b_is_alone As Boolean b_is_alone = IIf(cell.Rows.Count + cell.Columns.Count <> 2, False, True) If IsNumeric(cell.Value) And Not cell.HasFormula Then cell.Value = Round(cell.Value, 2) End If cell.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" If b_change_0 Then With cell .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=0" .FormatConditions(1).Font.ThemeColor = xlThemeColorDark1 .FormatConditions(1).Font.TintAndShade = -0.4 End With End If If b_is_alone Then If b_make_gray And cell.Value = 0 Then With cell .Cells.Font.Color = RGB(191, 191, 191) End With End If End If End Sub Public Function millions_eur(ByVal my_value As Long) As Long millions_eur = my_value / 1000000 End Function Public Sub WhiteYourself(ByVal lines As Long, ByRef my_sheet As Worksheet) Dim str_lines As String str_lines = lines & ":" & lines With my_sheet.Rows(str_lines).Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End Sub Public Sub WhiteCell(ByRef my_cell As Range) my_cell.Font.ThemeColor = xlThemeColorDark1 my_cell.Font.TintAndShade = 0 End Sub Public Sub FormatFontColorToGrey(ByRef cell As Range) cell.Font.Color = RGB(128, 128, 128) End Sub Public Function sum_range(my_range As Range) As Double Dim cell As Range sum_range = 0 For Each cell In my_range sum_range = sum_range + cell.Value Next End Function Public Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row End Function Sub CopyValues(rngSource As Range, rngTarget As Range) rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value End Sub Public Sub FormatRedAndBold(ByRef my_cell As Range, Optional isBold = True) my_cell.Font.Color = -16777063 my_cell.Font.TintAndShade = 0 If isBold Then my_cell.Font.Bold = True End Sub Public Function check_if_hidden(r_range As Range) As Boolean If r_range.EntireRow.Hidden Or r_range.EntireColumn.Hidden Then check_if_hidden = True End If End Function Function NamedRangeExists(strRangeName As String) As Boolean Dim my_range As Range On Error Resume Next Set my_range = Range(strRangeName) If Not my_range Is Nothing Then NamedRangeExists = True On Error GoTo 0 End Function Public Sub FormatAs_Eur_pro_m2(my_cell As Range) my_cell.NumberFormat = "#,##0.00 "" € / m²""" End Sub Sub change_all_names() Dim i As Integer Dim s_old As String Dim s_new As String For i = 1 To ActiveWorkbook.Names.Count ' Debug.Print ActiveWorkbook.Names(i).name ' Debug.Print ActiveWorkbook.Names(i).RefersToR1C1 ' Debug.Print ActiveWorkbook.Names(i) ' If InStr(1, ActiveWorkbook.Names(i), "old", vbTextCompare) Then s_old = ActiveWorkbook.Names(i).RefersToR1C1 s_new = Replace(s_old, "old", "") Debug.Print s_new With ActiveWorkbook.Names(ActiveWorkbook.Names(i).name) .RefersToR1C1 = s_new End With End If Next i End Sub Sub Fixing() tbl_Input.img_coat_of_arms.BackColor = RGB(217, 217, 217) End Sub Public Sub SetUserNameAndDate() [input_calculation_date] = Date [input_user_name] = "Erstellt von " & Replace(Application.WorksheetFunction.Proper(Environ("UserName")), ".", ". ") End Sub Public Sub SetNamedRanges() 'start setting named range for ma_purchase_ba If NamedRangeExists("ma_purchase_ba") Then ActiveWorkbook.Names("ma_purchase_ba").Delete ThisWorkbook.Names.Add name:="ma_purchase_ba", RefersTo:=tbl_output.Cells(8, 3) 'end setting named range End Sub Public Function locate_bau_beginn(ByVal d_baubeginn As Date) As Long Dim cell_to_find As Range Set cell_to_find = Range(tbl_output.Cells(1, 1), tbl_output.Cells(1, arr_calendar_settings(3))).Find(d_baubeginn, LookIn:=xlValues) locate_bau_beginn = cell_to_find.Column Set cell_to_find = Nothing End Function Public Function get_last_day_of_month(ByVal my_date As Date) As Date get_last_day_of_month = DateSerial(Year(my_date), month(my_date) + 1, 0) End Function Public Function get_first_day_of_month(ByVal my_date As Date) As Date get_first_day_of_month = DateSerial(Year(my_date), month(my_date), 1) End Function Public Function add_months(ByVal my_date As Date, ByVal i_month As Integer) As Date add_months = get_last_day_of_month(DateAdd("m", i_month, my_date)) End Function Public Function add_months_and_get_first_date(ByVal my_date As Date, ByVal i_month As Integer) As Date add_months_and_get_first_date = get_first_day_of_month(DateAdd("m", i_month, my_date)) End Function Public Sub FreezePanesWithoutSelect() Dim ws As Worksheet Application.ScreenUpdating = False Set ws = Worksheets("master") Application.Goto ws.Range("E2") ActiveWindow.FreezePanes = True Set ws = Nothing End Sub Public Function get_column_with_value(ByRef my_cell) As Long get_column_with_value = my_cell.End(xlToRight).Column End Function Public Sub OnStart() Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False End Sub Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False End Sub Public Sub UpdateStatusBar() Dim i As Integer Dim s_show As String On Error GoTo UpdateStatusBar_Error If int_number_of_subs = 0 Then int_number_of_subs = 1 int_current_sub = int_current_sub + 1 s_show = "/\/\>-" For i = 0 To int_number_of_subs Step 1 If int_current_sub <> i Then s_show = s_show & "~~~" Else s_show = s_show & "\___/" End If Next i s_show = s_show & "- CLng(TempArray(i + 1)) Then NoExchanges = False Temp = TempArray(i) TempArray(i) = TempArray(i + 1) TempArray(i + 1) = Temp End If Next i Loop While Not (NoExchanges) bubble_sort = TempArray End Function Public Function sum_array(my_array As Variant) As Double 'For unknown reasons, WorksheetFunction.sum(my_array) does not work always, 'when we sum currency, integer and double... Dim l_counter As Long For l_counter = LBound(my_array) To UBound(my_array) sum_array = sum_array + my_array(l_counter) Next l_counter End Function Public Function b_value_in_array(my_value As Variant, my_array As Variant) As Boolean Dim l_counter For l_counter = LBound(my_array) To UBound(my_array) my_array(l_counter) = CStr(my_array(l_counter)) Next l_counter b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0)) End Function Function last_row(Optional str_sheet As String, Optional column_to_check As Long = 1) As Long Dim shSheet As Worksheet If str_sheet = vbNullString Then Set shSheet = ActiveSheet Else Set shSheet = Worksheets(str_sheet) End If last_row = shSheet.Cells(shSheet.Rows.Count, column_to_check).End(xlUp).Row End Function Function last_column(Optional str_sheet As String, Optional row_to_check As Long = 1) As Long Dim shSheet As Worksheet If str_sheet = vbNullString Then Set shSheet = ActiveSheet Else Set shSheet = Worksheets(str_sheet) End If last_column = shSheet.Cells(row_to_check, shSheet.Columns.Count).End(xlToLeft).Column End Function Sub SaveFile A = Application.GetSaveAsFilename(InitialFileName:=environ("username") & "_"&ThisWorkbook.Name , fileFilter:="Excel Files (*.xlsm), *.xlsm") end Sub Public Function b_val_in_array(var_to_search As Variant, my_array As Variant) As Boolean Dim object As Variant For Each object In my_array If CStr(var_to_search) = CStr(object) Then b_val_in_array = True Exit Function End If Next object b_val_in_array = False End Function ================================================ FILE: __Arch/mod_functions.vb ================================================ Option Explicit Public Function sum_range(my_range As Range) As Double Dim cell As Range sum_range = 0 For Each cell In my_range sum_range = sum_range + cell.Value Next End Function Sub PrintLines() ActiveSheet.DisplayPageBreaks = Not ActiveSheet.DisplayPageBreaks End Sub Sub CheckReferences() ' Check for possible missing or erroneous links in ' formulas and list possible errors in a summary sheet Dim iSh As Integer Dim sShName As String Dim c As Range Dim rng As Range Dim i As Integer Dim j As Integer Dim sChr As String Dim addr As String Dim sFormula As String Dim scVal As String Dim lNewRow As Long Dim vHeaders As Variant vHeaders = Array("Sheet Name", "Cell", "Cell Value", "Formula") 'check if 'Summary' worksheet is in workbook 'and if so, delete it With Application .ScreenUpdating = False .DisplayAlerts = False .Calculation = xlCalculationManual End With For i = 1 To Worksheets.Count If Worksheets(i).Name = "Summary" Then Worksheets(i).Delete End If Next i iSh = Worksheets.Count 'create a new summary sheet Sheets.Add After:=Sheets(iSh) Sheets(Sheets.Count).Name = "Summary" With Sheets("Summary") Range("A1:D1") = vHeaders End With lNewRow = 2 ' this will not work if the sheet is protected, ' assume that sheet should not be changed; so ignore it On Error Resume Next For i = 1 To iSh sShName = Worksheets(i).Name Application.Goto Sheets(sShName).Cells(1, 1) Set rng = Cells.SpecialCells(xlCellTypeFormulas, 23) For Each c In rng addr = c.Address sFormula = c.Formula scVal = c.Text For j = 1 To Len(c.Formula) sChr = Mid(c.Formula, j, 1) If sChr = "[" Or sChr = "!" Or IsError(c) Then 'write values to summary sheet With Sheets("Summary") .Cells(lNewRow, 1) = sShName .Cells(lNewRow, 2) = addr .Cells(lNewRow, 3) = scVal .Cells(lNewRow, 4) = "'" & sFormula End With lNewRow = lNewRow + 1 Exit For End If Next j Next c Next i ' housekeeping With Application .ScreenUpdating = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End With ' tidy up Sheets("Summary").Select Columns("A:D").EntireColumn.AutoFit Range("A1:D1").Font.Bold = True Range("A2").Select End Sub Public Sub print_array(my_array As Variant) Dim counter As Integer For counter = LBound(my_array) To UBound(my_array) Debug.Print counter & " --> " & my_array(counter) Next counter End Sub Public Function get_last_day_of_month(my_date As Date) As Date get_last_day_of_month = DateSerial(Year(my_date), Month(my_date) + 1, 0) End Function Public Function add_months(my_date As Date, i_month As Integer) As Date add_months = get_last_day_of_month(DateAdd("m", i_month, my_date)) End Function Public Sub ShowMeTheNames() Dim i As Integer For i = 1 To ActiveWorkbook.Names().Count Debug.Print vbCrLf & ActiveWorkbook.Names(i).Name Debug.Print ActiveWorkbook.Names(i).RefersTo Next i End Sub Public Sub Normal() Application.ScreenUpdating = False Application.EnableEvents = False Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)" Application.DisplayStatusBar = True Application.DisplayFormulaBar = True ActiveWindow.DisplayHeadings = True Application.ScreenUpdating = True Application.EnableEvents = True End Sub Public Function last_row_with_data(ByVal lng_column_number As Long, shCurrent As Variant) As Long last_row_with_data = shCurrent.Cells(Rows.Count, lng_column_number).End(xlUp).Row End Function Sub CopyValues(rngSource As Range, rngTarget As Range) rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value End Sub ================================================ FILE: __Arch/mod_public.vb ================================================ Option Explicit Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) ================================================ FILE: __Arch/mod_remove_styles.vb ================================================ Option Explicit Sub RemoveTheStyles() Dim s As Style Dim i As Long Dim c As Long If ActiveWorkbook.MultiUserEditing Then If MsgBox("You cannot remove Styles in a Shared workbook." & vbCr & vbCr & _ "Do you want to unshare the workbook?", vbYesNo + vbInformation) = vbYes Then ActiveWorkbook.ExclusiveAccess If Err.Description = "Application-defined or object-defined error" Then Exit Sub End If Else Exit Sub End If End If c = ActiveWorkbook.Styles.Count Application.ScreenUpdating = False For i = c To 1 Step -1 If i Mod 600 = 0 Then DoEvents Set s = ActiveWorkbook.Styles(i) Application.StatusBar = "Deleting " & c - i + 1 & " of " & c & " " & s.Name If Not s.BuiltIn Then s.Delete End If Next Application.ScreenUpdating = True Application.StatusBar = False End Sub ================================================ FILE: __Arch/mod_shortcuts.vb ================================================ Sub ctrl_plus_u() ' Tastenkombination: Strg + U If Selection.Font.Underline = xlUnderlineStyleSingle Then Selection.Font.Underline = xlUnderlineStyleNone Else Selection.Font.Underline = xlUnderlineStyleSingle End If End Sub Sub ctrl_plus_b() ' Tastenkombination: Strg + B Selection.Font.Bold = Not Selection.Font.Bold End Sub Public Sub ctrl_plus_i() ' Tastenkombination: Strg + I Selection.Font.Italic = Not Selection.Font.Italic End Sub Sub ctrl_plus_d() ' Tastenkombination: Strg + D Selection.FillDown End Sub ================================================ FILE: __Arch/proposal_to_update.vb ================================================ 'github.com/timhall/Excel-TDD 'SpecExpectation Private Function IsEqual(Actual As Variant, Expected As Variant) As Variant Dim l_count As Long 'here vitosh If IsArray(Expected) Then For l_count = LBound(Expected) To UBound(Expected) If Not Expected(l_count) = Actual(l_count) Then Debug.Print l_count IsEqual = False Exit Function End If Next l_count End If 'end If IsError(Actual) Or IsError(Expected) Then IsEqual = False ElseIf IsObject(Actual) Or IsObject(Expected) Then IsEqual = "Unsupported: Can't compare objects" ElseIf VarType(Actual) = vbDouble And VarType(Expected) = vbDouble Then ' It is inherently difficult/almost impossible to check equality of Double ' http://support.microsoft.com/kb/78113 ' ' Compare up to 15 significant figures ' -> Format as scientific notation with 15 significant figures and then compare strings IsEqual = IsCloseTo(Actual, Expected, 15) Else IsEqual = Actual = Expected End If End Function ================================================ FILE: __Arch/protectsheet.vb ================================================ Option Explicit Sub main() 'This protects the code only tbl_main.Protect UserInterfaceOnly:=True End Sub Public Sub UnprotectAll() Dim i As Long For i = ActiveWorkbook.Worksheets.Count To 1 Step -1 ActiveWorkbook.Worksheets(i).Unprotect Password:=s_CONST Next End Sub Public Sub UnhideAll() Dim Sheet As Worksheet For Each Sheet In ThisWorkbook.Sheets Sheet.Visible = xlSheetVisible Next Sheet End Sub ================================================ FILE: __Arch/quick_unlock.vb ================================================ Public Function b_value_in_array(my_value As Variant, my_array As Variant, Optional b_is_string As Boolean = False) As Boolean Dim l_counter If b_is_string Then my_array = Split(my_array, ":") End If For l_counter = LBound(my_array) To UBound(my_array) my_array(l_counter) = CStr(my_array(l_counter)) Next l_counter b_value_in_array = Not IsError(Application.Match(CStr(my_value), my_array, 0)) End Function Public Sub aaa() 'easy to write and easy to remember If Not b_value_in_array(Environ("Username"), ADMINS, True) Then Debug.Print "no" Exit Sub End If Call UnhideAll 'UnprotectAll is included Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" ActiveWindow.DisplayHeadings = True Application.DisplayFormulaBar = True Debug.Print "a" End Sub ================================================ FILE: __Arch/readme.md ================================================ ### I just do not want to delete these, so they are here ================================================ FILE: __Arch/recursive_loop.vb ================================================ Option Explicit Sub EmbeddedLoops() Static size As Long Static c As Variant Static arr As Variant Static n As Long size = 4 c = Array(1, 2, 3, 4, 5, 6) n = UBound(c) + 1 ReDim arr(size - 1) Call embedded_loops(0, size, c, n, arr) End Sub Function embedded_loops(index, k, c, n, arr) Dim i As Variant If index >= k Then Call print_array_one_line(arr) Else For Each i In c arr(index) = i Call embedded_loops(index + 1, k, c, n, arr) Next i End If End Function Public Sub print_array_one_line(my_array As Variant) Dim counter As Integer Dim s_array As String For counter = LBound(my_array) To UBound(my_array) s_array = s_array & my_array(counter) Next counter Debug.Print s_array End Sub ================================================ FILE: __Arch/refer_cell_in_named_range.vb ================================================ ' how to refer cell in named range ' refer cell in named range ?[set_seconds_runtime].cells(3,1) ================================================ FILE: __Arch/relevant_months.vb ================================================ Option Explicit Public Function relevant_month(ByVal dt_date As Date) As String relevant_month = WorksheetFunction.Choose(Month(dt_date), "jan", "feb", ",mar", "apr", "may", "jun", "jul", "aug", "sep", "oct", "nov", "dec") relevant_month = relevant_month & "_" & Right(Year(dt_date), 2) End Function Public Function relevant_month_de(ByVal dt_date As Date) As String relevant_month_de = LCase(MonthName(Month(dt_date), True) & "_" & Right(Year(dt_date), 2)) End Function Public Sub CheckName() Debug.Print relevant_month_de(Now() + 40) Debug.Print relevant_month(Now() + 40) End Sub Public Function bad_example() If public_date <= #12/31/2005# Then relevant_month = "dec_05" ElseIf (public_date > #12/31/2005# And public_date <= #1/31/2006#) Then relevant_month = "jan_06" '300 lines more with elseifs Else relevant_month = "jan_18" End If send_relevant_month = relevant_month End Function Does not compile, Does not take lump years, Does not run automatically ================================================ FILE: __Arch/removeNamedRanges.vb ================================================ Public Sub RemoveNamedRanges() Dim nName As Name Dim strNameReserved As String On Error Resume Next strNameReserved = "set_in_production" For Each nName In Names If nName.Name <> strNameReserved And Left(nName.Name, 1) <> "_" Then Debug.Print nName.Name nName.Delete End If Next nName On Error GoTo 0 End Sub ================================================ FILE: __Arch/remove_msgbox.txt ================================================ For Excel 2007 Version : You can follow the following steps to avoide the privacy warning. 1 Menu Button "on the top left of the excel window" 2 Excel Option 3 Trust Center 4 Trust Center setting 5 Privacy Options 6 unmark the "Remove personal information from file properties on save" ================================================ FILE: __Arch/remove_spaces.vb ================================================ Public Sub removeSpaceInString() Dim myCell As Range For Each myCell In Selection myCell = Trim(myCell) myCell = Replace(myCell, vbTab, "") myCell = Replace(myCell, " ", "") myCell = Replace(myCell, Chr(160), "") Next myCell End Sub ================================================ FILE: __Arch/revealer.vb ================================================ Sub revealer() 'kto ti e interestno Dim i As Integer, j As Integer, k As String Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox "One usable is " & Chr(i) & Chr(j) & _ Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Sub 'First thing first Option Explicit Private Const PAGE_EXECUTE_READWRITE = &H40 Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _ (Destination As Long, Source As Long, ByVal Length As Long) Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _ ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _ ByVal lpProcName As String) As Long Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _ ByVal pTemplateName As Long, ByVal hWndParent As Long, _ ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer Dim HookBytes(0 To 5) As Byte Dim OriginBytes(0 To 5) As Byte Dim pFunc As Long Dim Flag As Boolean Private Function GetPtr(ByVal Value As Long) As Long GetPtr = Value End Function Public Sub RecoverBytes() If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6 End Sub Public Function Hook() As Boolean Dim TmpBytes(0 To 5) As Byte Dim p As Long Dim OriginProtect As Long Hook = False pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA") If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6 If TmpBytes(0) <> &H68 Then MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6 p = GetPtr(AddressOf MyDialogBoxParam) HookBytes(0) = &H68 MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4 HookBytes(5) = &HC3 MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6 Flag = True Hook = True End If End If End Function Private Function MyDialogBoxParam(ByVal hInstance As Long, _ ByVal pTemplateName As Long, ByVal hWndParent As Long, _ ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer If pTemplateName = 4070 Then MyDialogBoxParam = 1 Else RecoverBytes MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _ hWndParent, lpDialogFunc, dwInitParam) Hook End If End Function 'second thing second Sub unprotected() If Hook Then MsgBox "Ale!" End If End Sub ================================================ FILE: __Arch/selection_range_trick.vb ================================================ Public Sub SelectAndChange() Dim current_cells_range As Range Dim my_array As Variant Dim l_step_between_BA As Long Dim l_counter As Long Dim l_counter_2 As Long Dim l_counter_3 As Long Dim col As Long Dim row As Long l_step_between_BA = 17 col = Selection.Column row = Selection.row 'Beware what you select, for it would stay selected! :) Set current_cells_range = Selection For l_counter = 0 To 9 Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + l_step_between_BA * l_counter, col)) ' Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + 1 + l_step_between_BA * l_counter, col)) ' ' Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + 2 + l_step_between_BA * l_counter, col)) ' ' Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + 3 + l_step_between_BA * l_counter, col)) ' ' Set current_cells_range = Union(current_cells_range, ActiveSheet.Cells(row + 4 + l_step_between_BA * l_counter, col)) Next l_counter current_cells_range.Select End Sub ================================================ FILE: __Arch/string_generator.vb ================================================ 'random generator string 'string generator 'string degenerator 'string code decode coder decoder codify decodify Public Function str_generator(str_value As String, b_fix As Boolean) As String Dim l_counter As Long Dim l_number As Long Dim str_char As String 'On Error GoTo str_generator_Error If b_fix Then str_value = Left(str_value, Len(str_value) - 1) str_value = Right(str_value, Len(str_value) - 1) End If For l_counter = 1 To Len(str_value) str_char = Mid(str_value, l_counter, 1) If b_is_odd(l_counter) Then l_number = Asc(str_char) + IIf(b_fix, -2, 2) Else l_number = Asc(str_char) + IIf(b_fix, -6, 6) End If str_generator = str_generator + Chr(l_number) Next l_counter If Not b_fix Then str_generator = Chr(l_number) & str_generator & Chr(l_number) End If On Error GoTo 0 Exit Function str_generator_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure str_generator of Function Modul1" End Function Public Function b_is_odd(l_number As Long) As Boolean b_is_odd = l_number Mod 2 End Function ================================================ FILE: __Arch/subsequence.vb ================================================ Option Explicit Public Const NO_PREVIOUS = -1 Sub Main() Dim arr_seq As Variant Dim arr_len As Variant Dim arr_pre As Variant Dim lng_best As Long arr_seq = Array(1, 2, -6, -5, -3, 23, 123, 3, 2, -23, -5, 54, 100, 200, 300, 1111, 23412, 3, 4, 5, 6, 7, 8, 9, 19, 65, 2) ReDim arr_len(UBound(arr_seq)) ReDim arr_pre(UBound(arr_seq)) lng_best = CalculateLongestIncreasingSubsequence(arr_seq, _ arr_len, _ arr_pre) Call print_array(arr_seq) Call print_array(arr_len) Call print_array(arr_pre) Call PrintLongestIncreasingSubsequance(arr_seq, arr_pre, lng_best) End Sub Public Sub PrintLongestIncreasingSubsequance(ByRef arr_seq As Variant, _ ByRef arr_pre As Variant, _ lng_best As Long) Dim arr_result As Variant Dim l_counter As Long: l_counter = 0 ReDim arr_result(1) While (lng_best <> NO_PREVIOUS) ReDim Preserve arr_result(l_counter) l_counter = l_counter + 1 arr_result(l_counter - 1) = arr_seq(lng_best) lng_best = arr_pre(lng_best) Wend Debug.Print Join(reverse_array(arr_result), " ") End Sub Public Function CalculateLongestIncreasingSubsequence(ByRef arr_seq As Variant, _ ByRef arr_len As Variant, _ ByRef arr_pre As Variant) As Long Dim lng_best_len As Long: lng_best_len = 0 Dim lng_best_ind As Long: lng_best_ind = 0 Dim x As Long Dim i As Long For x = LBound(arr_seq) To (UBound(arr_seq)) Step 1 arr_len(x) = 1 arr_pre(x) = NO_PREVIOUS For i = 0 To x Step 1 If (arr_seq(i) < arr_seq(x)) And (arr_len(i) + 1 > arr_len(x)) Then arr_len(x) = arr_len(i) + 1 arr_pre(x) = i If arr_len(x) > lng_best_len Then lng_best_len = arr_len(x) lng_best_ind = x End If End If Next i Next x CalculateLongestIncreasingSubsequence = lng_best_ind End Function Public Sub print_array(ByRef my_array As Variant) Dim counter As Long For counter = LBound(my_array) To UBound(my_array) Debug.Print counter & " --> " & my_array(counter) Next counter Debug.Print "------------------------------" End Sub Public Function reverse_array(ByVal my_array As Variant) As Variant Dim counter As Long Dim counter_2 As Long Dim arr_new As Variant ReDim arr_new(UBound(my_array) + 1) For counter = LBound(arr_new) To UBound(arr_new) - 1 counter_2 = UBound(arr_new) - counter - 1 arr_new(counter) = my_array(counter_2) Next counter reverse_array = arr_new End Function ================================================ FILE: __Arch/sum_array_with_optional.vb ================================================ Public Function sum_array(my_array As Variant, Optional last_values_not_to_calculate As Long = 0) As Double 'For unknown reasons, WorksheetFunction.sum(my_array) does not work always, 'when we sum currency, long and double... Dim l_counter As Long For l_counter = LBound(my_array) To UBound(my_array) - last_values_not_to_calculate sum_array = sum_array + my_array(l_counter) Next l_counter End Function ================================================ FILE: __Arch/sum_column.vb ================================================ Application.WorksheetFunction.sum(tbl_results.Columns(15)) Application.WorksheetFunction.sum(tbl_results.rows(15)) ================================================ FILE: __Arch/todo_in_a_new_project.vb ================================================ ToDo in a VBA project (Tasks for a boilerplate) : > Make OnStart and OnEnd modules > Make if [set_in_production] then on error goto Main_error > Play with the status bar > Show a vbmodeless form while the macro is running > Find a quick macro to lock and unlock the project > On start of the file: > Lock it > Hide Not needed sheets > Lock scroll > Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", false)" > On the end of the file: > Save and release all possible forbidden things (check Workbook_BeforeClose) > Disable Workbook_NewSheet > Make a quick unlock and view all option just for you > Disable copy and paste and F11 ================================================ FILE: __Arch/typenameAndvartype.vb ================================================ var_a = "test_me" ?typename(var_a) String ?vartype(var_a) 8 ================================================ FILE: __Arch/user_form_centre.vb ================================================ Private Sub UserForm_Activate() With Me .Top = CLng((Application.Height / 2 + Application.Top) - .Height / 2) .Left = CLng((Application.Width / 2 + Application.Left) - .Width / 2) End With End sub ================================================ FILE: __Arch/vba_dictionary_example.vb ================================================ Option Explicit Sub Dictionaries() Dim l_counter1 As Long Dim l_counter2 As Long Dim dicts(7) As Variant Dim predecessors As Variant Dim node As New Dictionary Set predecessors = New Dictionary Set dicts(0) = New Dictionary dicts(0).Add 5, Array(11) Set dicts(1) = New Dictionary dicts(1).Add 7, Array(11, 8) Set dicts(2) = New Dictionary dicts(2).Add 8, Array(9) Set dicts(3) = New Dictionary dicts(3).Add 11, Array(9, 10, 2) Set dicts(4) = New Dictionary dicts(4).Add 9, Array() Set dicts(5) = New Dictionary dicts(5).Add 3, Array(8, 10) Set dicts(6) = New Dictionary dicts(6).Add 2, Array() Set dicts(7) = New Dictionary dicts(7).Add 10, Array() For l_counter1 = 0 To UBound(dicts) Set node = dicts(l_counter1) If Not b_key_in_dict(predecessors, node.Keys(0)) Then Debug.Print node.Keys(0) predecessors.Add node.Keys(0), 0 End If 'Check if node has no children If UBound(node(node.Keys(0))) > 0 Then For l_counter2 = 0 To UBound(node.Items) If Not (b_key_in_dict(predecessors, node.Items(l_counter2)(0))) Then predecessors.Add node.Items(l_counter2)(0), 0 Else predecessors.Item(node.Items(l_counter2)(0)) = (node.Items(l_counter2)(0)) + 1 End If Next l_counter2 End If Next l_counter1 ' Set k = dicts(5) ' Debug.Print k.Item(3)(0) 'First Item in the array in k with key 3 ' Debug.Print k.Item(3)(1) 'Second Item in the array in k with key 3 ' Debug.Print UBound(k.Item(3)) 'Size of items in the array in k with key 3 (-1) ' Debug.Print k.Keys(0) 'First key of k ' Debug.Print UBound(k.Keys) 'Size of keys in k (-1) End Sub Public Function b_key_in_dict(ByVal dict As Dictionary, ByVal key As String) As Boolean 'called like -> b_key_in_dict(dicts(0),5) ' OR just use EXIST Dim l_counter As Long b_key_in_dict = False For l_counter = 0 To UBound(dict.Keys) If dict.Keys(l_counter) = key Then b_key_in_dict = True Next l_counter End Function ================================================ FILE: __Arch/xl_docName.vb ================================================ Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error GoTo Workbook_BeforeClose_Error Cancel = False ThisWorkbook.Save Application.DisplayAlerts = False Call HideNeeded Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" Application.DisplayAlerts = True ActiveWindow.DisplayHeadings = True Application.DisplayFormulaBar = True ActiveSheet.PageSetup.BlackAndWhite = False Me.Save Application.OnKey "%{F11}" On Error GoTo 0 Exit Sub Workbook_BeforeClose_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_BeforeClose of Sub xl_paku" End Sub Private Sub Workbook_NewSheet(ByVal Sh As Object) paku_message_title = tbl_settings.Range("AJ8") If Not tbl_settings.Visible Then With Application Application.ScreenUpdating = False Application.DisplayAlerts = False Sh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End With MsgBox (Environ("UserName") & ", Sie können Blätter nicht hinzufügen."), vbInformation, paku_message_title End If End Sub Private Sub Workbook_Open() On Error GoTo Workbook_Open_Error Call HideNeeded Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", false)" Application.DisplayFormulaBar = False [set_root_user] = False If Not b_value_in_array(Environ("username"), ADMINS, True) Then Application.OnKey "%{F11}", "" Application.WindowState = xlMaximized On Error GoTo 0 Exit Sub Workbook_Open_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_Open of Sub xl_paku" Me.Save ThisWorkbook.Close End Sub ================================================ FILE: __Arch/xl_main.vb ================================================ Option Explicit Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error GoTo Workbook_BeforeClose_Error Cancel = False ThisWorkbook.Save Application.DisplayAlerts = False Call HideNeeded Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", true)" Application.DisplayAlerts = True ActiveWindow.DisplayHeadings = True Application.DisplayFormulaBar = True Me.Save Application.AskToUpdateLinks = True Call EnableMySaves On Error GoTo 0 Exit Sub Workbook_BeforeClose_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_BeforeClose of Sub xl_paku" End Sub Private Sub Workbook_NewSheet(ByVal Sh As Object) If Not tbl_settings.Visible Then With Application Application.ScreenUpdating = False Application.DisplayAlerts = False Sh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End With MsgBox (Environ("UserName") & ", Sie können Blätter nicht hinzufügen."), vbInformation, ThisWorkbook.Name End If End Sub Private Sub Workbook_Open() On Error GoTo Workbook_Open_Error Call LockMe Call HideNeeded Call LockScroll(Array(tbl_main.Name, "A1:X107")) Call MinimizeRibbon ActiveWindow.WindowState = xlMaximized Application.WindowState = xlMaximized 'Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"", false)" 'ActiveWindow.DisplayHeadings = False Application.OnKey "^{W}", "DisabledCombination" Application.OnKey "^{w}", "DisabledCombination" Application.OnKey "^{E}", "InitializeFormTotals" Application.OnKey "^{e}", "InitializeFormTotals" Call CheckHowManyWbAreOpened tbl_main.Select 'tbl_main.tb_Show = False tbl_main.chb_delete = False tbl_main.Cells(1, 1).Select ActiveWindow.Zoom = 74 On Error GoTo 0 Exit Sub Workbook_Open_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_Open of Sub DieseArbeitsmappe", vbInformation, [set_planerkostenberechnung] End Sub Public Sub CheckHowManyWbAreOpened() On Error GoTo CheckHowManyWbAreOpened_Error If Workbooks.Count > 1 Then [set_more_instances] = True frmInfo.Show (vbModeless) frmInfo.lb_information = "Sie haben mehr als eine Instanz von Excel. Dies ist keine sehr gute Idee." frmInfo.Repaint Application.Wait (Now + TimeValue("00:00:05")) Unload frmInfo End If [set_more_instances] = False On Error GoTo 0 Exit Sub CheckHowManyWbAreOpened_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CheckHowManyWbAreOpened of Sub DieseArbeitsmappe" End Sub