README.md

My VBA Practice

VBA, maybe it could be my ancient future

<List>

• Enum Statement (2024.02.11)
• Simple Q&A with ChatGPT : Trial (2023.05.02)
• Erase Statement (2023.01.03)
• File System : Folder.Files (2022.07.15)
• File System : File.DateCreated (2022.07.12)
• ByRef vs ByVal (2022.06.05)
• Declare Plural Variable (2022.06.04)
• Color Scroll 2 (2021.12.01)
• Variable Scope (2011.11.29)
• Control Formula Calculation Option (2021.11.08)
• Read Binary File (2021.08.23)
• Try ~ Catch ~ Finally (2021.07.28)
• Color Scroll (2020.11.14)

Enum Statement (2024.02.11)

• Practice to use Enum statement

  • Declare the Enum data type and observe how values are assigned
  • Apply For loops, Select~Case statements to iterate through them
    • For loop seems adoptable only when the values are continuous and sequential
  • Can enhance readability by using Enum's element names that convey meaning rather than just plain integers when indexing arrays

• References

  • Microsoft Learn > VBA > Enum statement
  • VBA Planet > VBA Enums
  • WallStreetMojo > VBA ENUM

• Code and Output

  Code : Enum.bas

  Option Explicit

  Private Const SHEET_NAME As String = "ENUM"

  ' Define enumerations for days of the week
  
  '------------------------------------------------------------------
  ' Enum DaysOfWeek1
  ' Description: Enumerates the days of the week starting from Sunday.
  '------------------------------------------------------------------
  Private Enum DaysOfWeek1
      Sunday                              ' Sunday as the first day
      Monday
      Tuesday
      Wednesday
      Thursday
      Friday
      Saturday
  End Enum
  
  '------------------------------------------------------------------
  ' Enum DaysOfWeek2
  ' Description: Enumerates the days of the week starting from Sunday
  '             and assigns numerical values starting from 1.
  '------------------------------------------------------------------
  Private Enum DaysOfWeek2
      Sunday = 1                          ' Sunday assigned numerical value 1
      Monday
      Tuesday
      Wednesday
      Thursday
      Friday
      Saturday
  End Enum
  
  '------------------------------------------------------------------
  ' Enum DaysOfWeek3
  ' Description: Enumerates the days of the week and assigns custom
  '             numerical values to each day.
  '------------------------------------------------------------------
  Private Enum DaysOfWeek3
      Sunday = 1                          ' Sunday assigned numerical value 1
      Monday = 1                          ' Monday assigned numerical value 1
      Tuesday = 2
      Wednesday = 3
      Thursday = 5
      Friday = 8
      Saturday = 13
  End Enum
  
  '------------------------------------------------------------------
  ' Enum DaysOfWeek4
  ' Description: Enumerates the days of the week and assigns custom
  '             numerical values to each day.
  '------------------------------------------------------------------
  Private Enum DaysOfWeek4
      Sunday = 1
      Monday = 3
      Tuesday = 5
      Wednesday = 7
      Thursday = 6
      Friday = 4
      Saturday = 2
  End Enum

  ' Function to iterate through each day of the week in an enum
  
  '------------------------------------------------------------------
  ' TestEnumLoop
  ' Description: Iterates through each day of the week in the specified
  '              enum and prints the result to the Immediate Window.
  ' Parameters:
  '   - num: Integer indicating which enumeration to test.
  '------------------------------------------------------------------
  Sub TestEnumLoop(num As Integer)
  
      Dim outputText As String
      outputText = "TestEnumLoop(" & num & ") : "
  
      Select Case num
      Case 1
          Dim currentDay1 As DaysOfWeek1
          For currentDay1 = DaysOfWeek1.Sunday To DaysOfWeek1.Saturday
              outputText = outputText & currentDay1 & " "
          Next currentDay1
      Case 2
          Dim currentDay2 As DaysOfWeek2
          For currentDay2 = DaysOfWeek2.Sunday To DaysOfWeek2.Saturday
              outputText = outputText & currentDay2 & " "
          Next currentDay2
      Case 3
          Dim currentDay3 As DaysOfWeek3
          For currentDay3 = DaysOfWeek3.Sunday To DaysOfWeek3.Saturday
              outputText = outputText & currentDay3 & " "
          Next currentDay3
      Case 4
          Dim currentDay4 As DaysOfWeek4
          For currentDay4 = DaysOfWeek4.Sunday To DaysOfWeek4.Saturday
              outputText = outputText & currentDay4 & " "
          Next currentDay4
      Case 5
          Dim currentDay5 As DaysOfWeek1
          For currentDay5 = DaysOfWeek1.Sunday To DaysOfWeek1.Saturday
              Select Case currentDay5
                  Case DaysOfWeek1.Saturday, DaysOfWeek1.Sunday
                      outputText = outputText & currentDay5 & " "
                  Case Else
                      outputText = outputText & "X" & " "
              End Select
          Next currentDay5
      Case 6
          outputText = outputText & DaysOfWeek4.Sunday & " "
          outputText = outputText & DaysOfWeek4.Monday & " "
          outputText = outputText & DaysOfWeek4.Tuesday & " "
          outputText = outputText & DaysOfWeek4.Wednesday & " "
          outputText = outputText & DaysOfWeek4.Thursday & " "
          outputText = outputText & DaysOfWeek4.Friday & " "
          outputText = outputText & DaysOfWeek4.Saturday & " "
      End Select
  
      Debug.Print outputText
  
  End Sub

  ' Main function to run all TestEnumLoop functions
  
  '------------------------------------------------------------------
  ' Main
  ' Description: Clears the specified sheet and runs all TestEnumLoop
  '              functions to test different enumerations.
  '------------------------------------------------------------------
  Private Sub Main()
  
      Sheets(SHEET_NAME).Cells.Clear      ' Clear sheet before running tests
  
      Call TestEnumLoop(1)
      Call TestEnumLoop(2)
      Call TestEnumLoop(3)
      Call TestEnumLoop(4)
      Call TestEnumLoop(5)
      Call TestEnumLoop(6)
  
  End Sub

  Output

  TestEnumLoop(1) : 0 1 2 3 4 5 6 
  TestEnumLoop(2) : 1 2 3 4 5 6 7 
  TestEnumLoop(3) : 1 2 3 4 5 6 7 8 9 10 11 12 13 
  TestEnumLoop(4) : 1 2 
  TestEnumLoop(5) : 0 X X X X X 6 
  TestEnumLoop(6) : 1 3 5 7 6 4 2 

Simple Q&A with ChatGPT : Trial (2023.05.02)

• Seems to be related to the failure of making a payment after the end of the Free trial usage of the ChatGPT API, although the code appears to be working properly

• Pause the phase here as a commemoration of the failure(?) while the problem can be resolved by making a payment

• Plan to upload to the MyBizApps repository from the next version (improvised)

  

  Code : ChatGPT_QA_0.bas

  Option Explicit

  Private Type CellLocationsType
  
      endpoint As String
      model As String
      apiKey As String
      question As String
      answerRange As Range                                    ' Not String but Range
  
  End Type

  Private Sub SetCellLocations(ByRef thisType As CellLocationsType)
  
      thisType.endpoint = Range("C2").Value
      thisType.model = Range("C3").Value
      thisType.apiKey = Range("C4").Value
      thisType.question = Range("C7").Value
      Set thisType.answerRange = Range("C8")                  ' Don't forget `set`!
  
  End Sub

  Private Sub ChatGPT()
  
      Dim CellLocations As CellLocationsType
      Dim request As Object
      Dim request_body As String
      Dim response As String
  
      ' Set required data
      Call SetCellLocations(CellLocations)
  
      ' Clear the Answer cell
      CellLocations.answerRange.Value = ""
  
      ' Request ChatGPT API
      Set request = CreateObject("WinHttp.WinHttpRequest.5.1")
      request.Open "POST", "https://api.openai.com/" & CellLocations.endpoint, False
      request.SetRequestHeader "Content-Type", "application/json"
      request.SetRequestHeader "Authorization", "Bearer " & CellLocations.apiKey
      request_body = "{" & _
          """prompt"": """ & Replace(CellLocations.question, """", "\""") & """," & _
          """model"": """ & CellLocations.model & """," & _
          """max_tokens"": 4097," & _
          """n"": 1," & _
          """stop"": [""\n""]" & _
      "}"
      Debug.Print request_body
      request.Send request_body
  
      ' Output
      response = Replace(request.ResponseText, Chr(34), "")
      response = Replace(response, "\n", "")
      Debug.Print response
      CellLocations.answerRange.Value = response
  
  End Sub

  Private Sub btnRun_Click()
  
          Application.Calculation = xlManual
              Call ChatGPT
          Application.Calculation = xlAutomatic
  
  End Sub

  

Erase Statement (2023.01.03)

• Practices to use Erase for a static array and a dynamic array

  • Erase Static Array : just fills all the cells as 0
  • Erase Dynamic Array : completely sets it back as Type()
  Code : Erase.bas

  Option Explicit
  
  
  Private Sub Main()
  
      Dim T800(1 To 9)    As Integer
      Dim T1000()         As Integer
  
      Dim i As Integer, j As Integer, str As String
  
      ' 1. Static Array
      ' 1.1 Fill the array
      For i = 1 To 9
          T800(i) = i
      Next i
  
      ' 1.2 Print the array
      str = ""
      For i = 1 To 9
          str = str & T800(i)
      Next i
      Debug.Print str                                         ' 123456789
  
      ' 1.3 Erase the fixed array
      Erase T800
  
      ' 1.4 Print the array after erased
      str = ""
      For i = 1 To 9
          str = str & T800(i)
      Next i
      Debug.Print str                                         ' 000000000
  
      ' 2. Dynamic Array
      ' 2.1 Fill the array
      ReDim T1000(1 To 9)
      For i = 1 To 9
          T1000(i) = i
      Next i
  
      ' 2.2 Print the array
      str = ""
      For i = 1 To 9
          str = str & T1000(i)
      Next i
      Debug.Print str                                         ' 123456789
  
      ' 2.3 Erase the fixed array
      Erase T1000                                             ' become Integer()
  
      ' 2.4 Print the array after erased
  '    str = ""
  '    For i = 1 To 9
  '        str = str & T1000(i)                               ' error
  '    Next i
  '    Debug.Print LBound(T1000) & " " & UBound(T1000)        ' error
  
  End Sub

  123456789
  000000000
  123456789
  

File System : Folder.Files (2022.07.15)

• Get a file list from a folder through Folder object in VBA

• Reference : [Microsoft Docs] VBA > Objects > Folder Object

  

  Code : File_GetFolders.bas

  Option Explicit

  Sub GetFileList()
  
      ' Set zero point to print
      Dim printZero As Range
      Set printZero = Range("A5")
  
      ' Clear area to print
      Dim usingArea As Range
      Set usingArea = Range(printZero, printZero.Offset(10000, 3))
      usingArea.ClearContents
  
      ' Get path
      Dim path As String
      If Range("B1").Value <> "" Then
          path = Range("B1").Value
      Else
          path = ThisWorkbook.path & Application.PathSeparator
      End If
          ' Debug.Print path
  
      ' Get oFile collection's informations
      Dim oFSO, oFolder, oFile
      Dim i As Integer
      Set oFSO = CreateObject("Scripting.FileSystemObject")
      Set oFolder = oFSO.GetFolder(path)
          ' Debug.Print oFolder.Name
      For Each oFile In oFolder.Files                                             ' .Files property returns a Files collection consisting of all File objects
          printZero.Offset(i, 0) = oFile.Name
          printZero.Offset(i, 1) = oFile.Type
          printZero.Offset(i, 2) = oFile.Size
          printZero.Offset(i, 3) = oFile.DateCreated
          i = i + 1
      Next oFile
  
  End Sub

  Private Sub btnGetFileList_Click()
  
      Application.Calculation = xlManual
          Call GetFileList
      Application.Calculation = xlAutomatic
  
  End Sub

File System : File.DateCreated (2022.07.12)

• Read the DateCreated property from an external file through File object in VBA

• Reference : [Microsoft Docs] VBA > Objects > File Object

  

  Code : File_DateCreated.bas

  Option Explicit

  Sub ReadDateCreated()
  
      Dim fs, f, s
      Dim path As String
      path = ThisWorkbook.path & Application.PathSeparator & Range("B1").Value
          'Debug.Print path
      Set fs = CreateObject("Scripting.FileSystemObject")
      Set f = fs.GetFile(path)
      s = f.DateCreated
  
      Range("B2").Value = s
  
  End Sub

  Private Sub btnReadDateCreated_Click()
  
      Application.Calculation = xlManual
          Call ReadDateCreated
      Application.Calculation = xlAutomatic
  
  End Sub

ByRef vs ByVal (2022.06.05)

• One more technical issue, following the below topic, raised from Idea Generator v0.20 (2022.06.03)

• Don't ignore VBA users! We also understand the difference between Call by Reference and Call by Value!

• Further discussion
  · [Microsoft Docs] VB.NET > Passing Arguments by Value and by Reference
  · [Microsoft Docs] VBA > Array argument must be ByRef
  · [Microsoft Docs] VBA > Understanding parameter arrays

  Code : ByRef_vs_ByVal.bas

  Option Explicit

  Private Function fByRef(ByRef s As String)
  
      s = "바보"
  
  End Function

  Private Function fByVal(ByVal s As String)                  ' An array as a parameter can't be called by Value
  
      s = "바보"
  
  End Function

  Private Sub Main()
  
      Dim 마누라(1) As String
      Dim 남편(1) As String
  
      마누라(0) = "마누라"
      마누라(1) = "최고"
      남편(0) = "남편"
      남편(1) = "최고"
  
      Call fByRef(마누라(1))
      Call fByVal(남편(1))
  
      Debug.Print 마누라(0) & "는 " & 마누라(1) & "다."
      Debug.Print 남편(0) & "은 " & 남편(1) & "다."
  
  End Sub

  마누라는 바보다.
  남편은 최고다.

Declare Plural Variable (2022.06.04)

• A technical issue raised from Idea Generator v0.20 (2022.06.03)

• Every variable should be specified individually as its type although they are declared in a line.

• In the below cases, the result 0 means Empty (uninitialized) and 2 does Integer from VarType().
  ※ Reference ☞ [Microsoft Docs] VBA > VarType function > Return values

  Code : DeclarePluralVariable.bas

  Option Explicit

  Private Sub StupidDeclare()
  
      Dim a, b As Integer
  
      Debug.Print VarType(a) & " " & VarType(b)
  
  End Sub

  0 2

  Private Sub SmartDeclare()
  
      Dim a As Integer, b As Integer
  
      Debug.Print VarType(a) & " " & VarType(b)
  
  End Sub

  2 2

Color Scroll 2 (2021.12.01)

• Advanced from Color Scroll (2020.11.14) : succeed in making it move!

• Use array Application.Calculation RGB(), without Select/Selection

  

  Code : ColorScroll2.bas

  Option Explicit
  
  'Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)   ' actually it is somewhat crazy to declare it as Private

  Sub ColorScroll2()
  
      Dim width, interval As Integer
      Dim base(2), rgbCol(2) As Integer                                               ' 2 means 0 to 2 (size : 3)
  
      width = 96
      interval = 16
  
      base(0) = 0
      base(1) = 127
      base(2) = 255
  
      Dim i, j, k As Integer
  
      ' shift i times
      For i = 1 To 100
  
          Application.Calculation = xlManual
  
              ' i-th drawing
              For j = 1 To width
  
                  ' for base(0 ~ 2)
                  For k = 0 To 2
  
                      If (base(k) \ 256) Mod 2 = 0 Then                               ' / : don't operate as int / int
                          rgbCol(k) = base(k) Mod 256
                      Else
                          rgbCol(k) = 256 - (base(k) Mod 256)
                      End If
  
                      ' test
                      'Cells(2 + k, j) = rgbCol(k)
  
                      base(k) = base(k) + interval
  
                  Next k
  
                  Cells(1, j).Interior.Color = RGB(rgbCol(0), rgbCol(1), rgbCol(2))   ' not .ColorIndex
  
              Next j
  
          Application.Calculation = xlAutomatic
  
          base(0) = base(0) + interval                                                ' is it the best?
          base(1) = base(1) + interval
          base(2) = base(2) + interval
  
  '        Sleep (100)
  
      Next i
  
  End Sub

  Sub Reset()
  'Initialize the sheet
  
      Cells.Select
      Selection.Clear
  
      Selection.ColumnWidth = 1
      Selection.RowHeight = 10
      Cells(1, 1).RowHeight = 409                                                     ' 409 : the max row height supported by Excel
  
  End Sub

Variable Scope (2011.11.29)

• Load several operation results into Public variables and call them into local Sub procedure

• I don't think it is an enough practice but my front line now here ……

  

  Code : Scope.bas

  '----------------------------------------------------------------------------------------
  ' Module1
  Option Explicit
  
  
  Public num1, num2, res(7) As Integer
  
  
  Sub Operate()
  
      num1 = ActiveSheet.Range("B1")
      num2 = ActiveSheet.Range("B2")
  
      res(0) = num1 + num2
      res(1) = num1 - num2
      res(2) = num1 * num2
      res(3) = num1 / num2
      res(4) = num1 \ num2                                        ' no difference from '/' because of Integer / Integer
      res(5) = num1 Mod num2
      res(6) = num1 ^ num2
      res(7) = num1 >= num2                                       ' why -1 when num1 = 5, num2 = 2?
  
  End Sub

  '----------------------------------------------------------------------------------------
  ' Sheet1
  Sub ReadResults()
  
      Dim i As Integer
      For i = 0 To 7
          ActiveSheet.Range("B" & 3 + i) = res(i)
      Next i
  
  '    Range("B3:B10").Value = res                                ' why doesn't it work?
  '    Range("B3:B10").Value = WorksheetFunction.Transpose(res)   ' it works but I want to avoid WorkSheetFunction() if possible
  
  End Sub

Control Formula Calculation Option (2021.11.08)

• Control Excel's formula calculation option by Application.Calculation method

• Working with xlManual status is much faster than xlAutomatic

  

  Code : FormulaCalcOption.bas

  Option Explicit

  ' Make a sample case that contains many calculations
  Sub sampleWork()
  
      ' Set range
      Dim row, rowEnd, col, colEnd As Integer
      row = 1
      rowEnd = 34
      col = row
      colEnd = rowEnd
  
      ' Generate formula n * n times
      While row <= rowEnd
      
          While col <= colEnd
  
              If (row = rowEnd And col = colEnd) Then
                  Sheet1.Cells(row, col) = rowEnd * 3 - 3
              ElseIf (col = colEnd) Then
                  Sheet1.Cells(row, col).FormulaR1C1 = "=R[+1]C-3"    ' 삼천포 you nahm sayin
              Else
                  Sheet1.Cells(row, col).FormulaR1C1 = "=RC[+1]-3"
              End If
  
              col = col + 1
  
          Wend
  
          col = 1
          row = row + 1
  
      Wend
  
  End Sub

  

  Code : FormulaCalcOption.bas

  ' Skip excel formula calculation temporarily
  Sub SkipFormulaCalc()
  
      Application.Calculation = xlManual
          Call sampleWork
      Application.Calculation = xlAutomatic
      
  End Sub

Read Binary File (2021.08.23)

• Use Open ~ For ~ As statement

• path requires absoulte one

  Code : ReadBinaryFile.bas - Trial 1

  Option Explicit
  
  
  Sub ReadBinaryFile()
  
      'Call the target file's path that user entered
      Dim path As String
      path = Range("B1")
  
      'Check if the file exists
      Dim fileChk As Boolean                      'default : False
      If (Len(Dir(path)) > 0) Then fileChk = True
      Range("B2") = fileChk
  
      Dim fn As Integer                           'fn : file number
      fn = FreeFile
  
      Dim output As Range
      Set output = Range("B5")                    'set offset location for output
  
      Open path For Binary Access Read As #fn
      
          Dim pos, posEnd As Integer
          pos = 1
          posEnd = 10
          
          Dim data As Byte
  
          While pos <= posEnd
              Get #fn, pos, data
              output.Offset(0, pos).Value = data
              pos = pos + 1
          Wend
  
      Close #fn
  
  End Sub

  ☞ data doesn't work well.

  

  

  Code : ReadBinaryFile.bas - Trial 2

  ☞ receive advice from Can't read binary file data (StackOverflow)

  Before :

  path = Range("B1")

  After :

  path = ThisWorkbook.path & Application.PathSeparator & Range("B1")

  

Try Catch Finally (2021.07.28)

• Use Try ~ Catch ~ Finally statement in VBA

• Actually VBA doesn't support it officially, but we can imitate it with label based on GoTo grammar.

  

  

  Code : TryCatchFinally.bas

  Option Explicit
  
  
  Function Divide(a As Integer, b As Integer) As Integer
  
  Try:                                                ' the below lines will run regardless of this
      
      On Error GoTo Catch
          Divide = a / b                              ' occurs en error when b = 0 or any possible cases (I can't imagine but ……)
      
      GoTo Finally                                    ' pass Catch: when it doesn't occur an error
      
  Catch:
      
      If b = 0 Then
          MsgBox "An error occurs : division by zero."
  '    Else                                           ' When b is not entered, it calls 0 as a default value.
  '        MsgBox "An error occurs."
      End If
      
      Exit Function                                   ' need not to run under Finally:
  
  Finally:
      
      MsgBox Divide                                   ' I have no any other idea to use Finally:
  
  End Function

Color Scroll (2020.11.14)

• Make a color matrix by Nested For statement

• Want to make it flow, but it doesn't work well yet

  

  Code : ColorScroll.bas

  Option Explicit

  Sub ColorScroll()
  
      Dim StartRow As Integer, StartColumn As Integer, Width As Integer, Height As Integer
      Dim i As Integer, j As Integer, k As Integer
      Dim FirstColumn As Range, LastColumn As Range
  
      StartRow = 1
      StartColumn = 1
      Width = 56
      Height = 56
  
      Range(Cells(StartRow, StartColumn), Cells(Height, Width)).Select
      Selection.RowHeight = 10
      Selection.ColumnWidth = 1
  
      For i = 1 To Height
          For j = 1 To Width
              Cells(i, j).Interior.ColorIndex = (i + j) Mod 56 + 1
          Next j
      Next i
  
  '    Differnt result from debugging mode and normal run mode(F5)
  '    For k = 1 To Width
  '        Columns(Width).Select
  '        Selection.Cut
  '        Columns(1).Select
  '        Selection.Insert Shift:=xlToRight
  '    Next k
  
  End Sub

  Sub Reset()
  'Initialize the sheet
  
      Cells.Select
      Selection.Clear
  
      Selection.ColumnWidth = 10
      Selection.RowHeight = 15
  
  End Sub