Snippets Collections
Sub CreateCalendar()
   'Define your variables
   Dim wks As Worksheet
   Dim var As Variant
   Dim datDay As Date
   Dim iMonth As Integer, iCol As Integer, iCounter As Integer, iYear As Integer
   Dim sMonth As String
   Dim bln As Boolean
   
   'In the current application, turn off screen updating, save the current state of the status bar,
   'and then turn on the status bar.
   With Application
      .ScreenUpdating = False
      bln = .DisplayStatusBar
      .DisplayStatusBar = True
   End With
   
   'Initialize iYear with the value entered in the first spin button on the worksheet.
   iYear = Cover.SpinButton1.Value
   
   'Create a new workbook to hold your new calendar.
   Workbooks.Add
   
   'In this new workbook, clear out all the worksheets except for one.
   Application.DisplayAlerts = False
   For iCounter = 1 To Worksheets.Count - 1
      Worksheets(2).Delete
   Next iCounter
   Application.DisplayAlerts = True
   
   
   Set wks = ThisWorkbook.Worksheets("Employee")
   
   'For each month of the year
   For iMonth = 1 To 12
      'Create a new worksheet and label the worksheet tab with the name of the new month
      sMonth = Format(DateSerial(1, iMonth, 1), "mmmm")
      Application.StatusBar = "Place month " & sMonth & " on..."
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = sMonth
      
      'Copy the employee names to the first column, and add the dates across the remaining columns.
      wks.Range(wks.Cells(3, 1), wks.Cells( _
         WorksheetFunction.CountA(wks.Columns(1)) + 1, 1)).Copy Range("A2")
      Range("A1").Value = "'" & ActiveSheet.Name & " " & iYear
      
      'Call the private subs, depending on what options are chosen for the calendar.
      
      'With weekends and holidays
      If Cover.OptionButton1.Value And Cover.OptionButton3.Value Then
         Call WithHW(iMonth)
      'With weekends, but without holidays
      ElseIf Cover.OptionButton1.Value And Cover.OptionButton3.Value = False Then
         Call WithWsansH(iMonth)
      'With holidays, but without weekends
      ElseIf Cover.OptionButton1.Value = False And Cover.OptionButton3.Value Then
         Call WithHsansW(iMonth)
      'Without weekends or holidays.
      Else
         Call SansWH(iMonth)
      End If
      
      'Apply some formatting.
      Rows(2).Value = Rows(1).Value
      Rows(2).NumberFormat = "ddd"
      Range("A2").Value = "Weekdays"
      Rows("1:2").Font.Bold = True
      Columns.AutoFit
   Next iMonth
   
   'Delete the first worksheet, because there was not anything in it.
   Application.DisplayAlerts = False
   Worksheets(1).Delete
   Application.DisplayAlerts = True
   
   'Label the window.
   Worksheets(1).Select
   ActiveWindow.Caption = "Yearly calendar " & iYear
   
   'Do some final cleanup, and then close out the sub.
   With Application
      .ScreenUpdating = True
      .DisplayStatusBar = bln
      .StatusBar = False
   End With
End Sub


'Name: WithWH (with weekends and holidays)
'Description: Creates a calendar for the specified month, including both weekends and holidays.
Private Sub WithHW(ByVal iMonth As Integer)
   'Define your variables.
   Dim cmt As Comment
   Dim rng As Range
   Dim var As Variant
   Dim datDay As Date
   Dim iYear As Integer, iCol As Integer
   iCol = 1
   iYear = Cover.SpinButton1.Value
   
   'Go through every day of the month and put the date on the calendar in the first row.
   For datDay = DateSerial(iYear, iMonth, 1) To DateSerial(iYear, iMonth + 1, 0)
      iCol = iCol + 1
      Set rng = Range(Cells(1, iCol), Cells(WorksheetFunction.CountA(Columns(1)), iCol))
      
      'Determine if the day is a holiday.
      var = Application.Match(CDbl(datDay), ThisWorkbook.Worksheets("Holidays").Columns(1), 0)
      Cells(1, iCol).Value = datDay
      
      'Add the appropriate formatting that indicates a holiday or weekend.
      With rng.Interior
         Select Case Weekday(datDay)
            Case 1
               .ColorIndex = 35
            Case 7
               .ColorIndex = 36
         End Select
         If Not IsError(var) Then
            .ColorIndex = 34
            Set cmt = Cells(1, iCol).AddComment( _
               ThisWorkbook.Worksheets("Holidays").Cells(var, 2).Value)
            cmt.Shape.TextFrame.AutoSize = True
         End If
      End With
   Next datDay
End Sub


'Name: WithHsansW (with holidays, without weekends)
'Description: Creates a calendar for the specified month, including holidays, but not weekends.
Private Sub WithHsansW(ByVal iMonth As Integer)
   'Declare your variables.
   Dim datDay As Date
   Dim iYear As Integer, iCol As Integer
   iCol = 1
   iYear = Cover.SpinButton1.Value
   
   'For every day in the month, determine if the day is a weekend.
   For datDay = DateSerial(iYear, iMonth, 1) To DateSerial(iYear, iMonth + 1, 0)
      
      'If the day is not a weekend, put it on the calendar.
      If WorksheetFunction.Weekday(datDay, 2) < 6 Then
         iCol = iCol + 1
         Cells(1, iCol).Value = datDay
      End If
   Next datDay
End Sub


'Name: WithWsansH (with weekends, without holidays)
'Description: Creates a calendar for the specified month, including weekends, but not holidays.
Private Sub WithWsansH(ByVal iMonth As Integer)
   'Declare your variables.
   Dim var As Variant
   Dim datDay As Date
   Dim iYear As Integer, iCol As Integer
   iCol = 1
   iYear = Cover.SpinButton1.Value
   
   'For every day in the month, determine if the day is a holiday.
   For datDay = DateSerial(iYear, iMonth, 1) To DateSerial(iYear, iMonth + 1, 0)
      var = Application.Match(CDbl(datDay), ThisWorkbook.Worksheets("Holidays").Columns(1), 0)
      
      'If the day is not a holiday, put it on the calendar.
      If IsError(var) Then
         iCol = iCol + 1
         Cells(1, iCol).Value = datDay
      End If
   Next datDay
End Sub


'Name: SansWH (without weekends or holidays)
'Description: Creates a calendar for the specified month, not including weekends or holidays.
Private Sub SansWH(ByVal iMonth As Integer)
   'Set up your variables
   Dim var As Variant
   Dim datDay As Date
   Dim iYear As Integer, iCol As Integer
   iCol = 1
   iYear = Cover.SpinButton1.Value
   
   'For every day in the month, determine if the day is a weekend or a holiday.
   For datDay = DateSerial(iYear, iMonth, 1) To DateSerial(iYear, iMonth + 1, 0)
      If WorksheetFunction.Weekday(datDay, 2) < 6 Then
         var = Application.Match(CDbl(datDay), ThisWorkbook.Worksheets("Holidays").Columns(1), 0)
         
         'If the day is not a weekend or a holiday, put it on the calendar.
         If IsError(var) Then
            iCol = iCol + 1
            Cells(1, iCol).Value = datDay
         End If
      End If
   Next datDay
End Sub
Dim mainWorkBook As Workbook
Dim arrMatrix(1 To 9, 1 To 3, 1 To 3)
Dim arrOptions(9)
Dim arrAlreadyUpdated()
Dim blnHaveSomethingToFill

Sub Sumit()
Set mainWorkBook = ActiveWorkbook
Call FnGetValues

blnHaveSomethingToFill = False
For i = 1 To 9
StrA = ""
'intAUCounter = 0
'ReDim Preserve arrAlreadyUpdated(0)
For j = 1 To 3
For k = 1 To 3
'MsgBox i & " " & j & "      " & arrMatrix(i, j)
If arrMatrix(i, j, k) = "" Then

Call FnFillOptionsArray
Call FnCalculate(i, j, k)
intCounterO = 0
'StrA = ""
For p = 0 To 8
StrA = StrA & "  " & arrOptions(p)
If arrOptions(p) = 0 Then
intCounterO = intCounterO + 1
End If
Next
If i = 4 Then
'MsgBox i & j & k & "     " & StrA
End If

'intAUCounter = intAUCounter + 1
'ReDim Preserve arrAlreadyUpdated(intAUCounter)
'arrAlreadyUpdated(intAUCounter - 1) = i & " " & j & " " & k
'MsgBox arrAlreadyUpdated(intAUCounter - 1) & " Entered"

If intCounterO = 8 Then
'intAUCounter = 0
For p = 0 To 8
If arrOptions(p) <> 0 Then
arrMatrix(i, j, k) = arrOptions(p)
'MsgBox "have"
blnHaveSomethingToFill = True
End If
Next
End If
End If
Next
Next
If blnHaveSomethingToFill = False Then
For a = 1 To 9
StrA = Replace(StrA, " ", "")
strTemp = StrA
If Len(strTemp) - Len(Replace(strTemp, CStr(a), "")) = 1 Then
' MsgBox StrA
intLocation = InStr(1, StrA, CStr(a), 1)
' MsgBox intLocation
intCell = 0
If Int(intLocation / 9) <> (intLocation / 9) Then
intCell = Int(intLocation / 9) + 1
Else
intCell = Int(intLocation / 9)
End If
' MsgBox intCell & " Location"
'arrTemp = Split(arrAlreadyUpdated(intCell - 1), " ")
'intI = CInt(arrTemp(0))
'intJ = CInt(arrTemp(1))
'intK = CInt(arrTemp(2))
' MsgBox intI & intJ & intK
intC = 0
blnFound = False
For j = 1 To 3
For k = 1 To 3
'MsgBox i & " " & j & "      " & arrMatrix(i, j)
If arrMatrix(i, j, k) = "" Then
''MsgBox "411" & arrMatrix(4, 1, 1)
intC = intC + 1
'MsgBox "intC" & intC
'MsgBox i & j & k
If intC = intCell Then
arrMatrix(i, j, k) = a
'Call FnFillValues
' MsgBox i & j & k & "Matched" & "   " & a
blnFound = True
Exit For
End If
End If
Next
If blnFound Then
Exit For
End If
Next
Exit For
StrA = ""
strTemp = ""
End If
Next

End If
Next

ReDim Preserve arrAlreadyUpdated(0)

Call FnFillValues

End Sub

Function FnFillOptionsArray()

arrOptions(0) = 1
arrOptions(1) = 2
arrOptions(2) = 3
arrOptions(3) = 4
arrOptions(4) = 5
arrOptions(5) = 6
arrOptions(6) = 7
arrOptions(7) = 8
arrOptions(8) = 9

End Function

Function FnCalculate(a, b, c)

For j = 1 To 3
For k = 1 To 3
If arrMatrix(a, j, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(a, j, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next

If a = 1 Then
For j = 1 To 3
For k = 1 To 3
If arrMatrix(j, k, c) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, k, c) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
For j = 1 To 7 Step 3
For k = 1 To 3
If arrMatrix(j, b, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, b, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
End If

If a = 2 Then
For j = 1 To 3
For k = 1 To 3
If arrMatrix(j, k, c) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, k, c) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
For j = 2 To 8 Step 3
For k = 1 To 3
If arrMatrix(j, b, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, b, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
End If

If a = 3 Then
For j = 1 To 3
For k = 1 To 3
If arrMatrix(j, k, c) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, k, c) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
For j = 3 To 9 Step 3
For k = 1 To 3
If arrMatrix(j, b, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, b, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
End If

If a = 4 Then
For j = 4 To 6
For k = 1 To 3
If arrMatrix(j, k, c) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, k, c) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
For j = 1 To 7 Step 3
For k = 1 To 3
If arrMatrix(j, b, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, b, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
End If

If a = 5 Then
For j = 4 To 6
For k = 1 To 3
If arrMatrix(j, k, c) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, k, c) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
For j = 2 To 8 Step 3
For k = 1 To 3
If arrMatrix(j, b, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, b, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
End If

If a = 6 Then
For j = 4 To 6
For k = 1 To 3
If arrMatrix(j, k, c) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, k, c) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
For j = 3 To 9 Step 3
For k = 1 To 3
If arrMatrix(j, b, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, b, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
End If

If a = 7 Then
For j = 7 To 9
For k = 1 To 3
If arrMatrix(j, k, c) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, k, c) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
For j = 1 To 7 Step 3
For k = 1 To 3
If arrMatrix(j, b, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, b, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
End If

If a = 8 Then
For j = 7 To 9
For k = 1 To 3
If arrMatrix(j, k, c) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, k, c) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
For j = 2 To 8 Step 3
For k = 1 To 3
If arrMatrix(j, b, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, b, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
End If

If a = 9 Then
For j = 7 To 9
For k = 1 To 3
If arrMatrix(j, k, c) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, k, c) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
For j = 3 To 9 Step 3
For k = 1 To 3
If arrMatrix(j, b, k) <> "" Then
For m = 0 To 8
If arrOptions(m) = arrMatrix(j, b, k) Then
arrOptions(m) = 0
End If
Next
End If
Next
Next
End If

End Function

Function FnGetValues()
'intChar = 69
'j = 1
'Set mainWorkBook = ActiveWorkbook
'For k = 1 To 9
'   For m = 69 To 77
'      For k = 1 To 3
'          For i = 1 To 3
'             arrMatrix(k, i, j) = mainWorkBook.Sheets("Sheet1").Range(Chr(m) & i + 4).Value
'        Next
'       j = j + 1
'  Next
'Next
'Next

arrMatrix(1, 1, 1) = mainWorkBook.Sheets("Sheet1").Range("E5").Value
arrMatrix(1, 2, 1) = mainWorkBook.Sheets("Sheet1").Range("E6").Value
arrMatrix(1, 3, 1) = mainWorkBook.Sheets("Sheet1").Range("E7").Value
arrMatrix(2, 1, 1) = mainWorkBook.Sheets("Sheet1").Range("E8").Value
arrMatrix(2, 2, 1) = mainWorkBook.Sheets("Sheet1").Range("E9").Value
arrMatrix(2, 3, 1) = mainWorkBook.Sheets("Sheet1").Range("E10").Value
arrMatrix(3, 1, 1) = mainWorkBook.Sheets("Sheet1").Range("E11").Value
arrMatrix(3, 2, 1) = mainWorkBook.Sheets("Sheet1").Range("E12").Value
arrMatrix(3, 3, 1) = mainWorkBook.Sheets("Sheet1").Range("E13").Value

arrMatrix(1, 1, 2) = mainWorkBook.Sheets("Sheet1").Range("F5").Value
arrMatrix(1, 2, 2) = mainWorkBook.Sheets("Sheet1").Range("F6").Value
arrMatrix(1, 3, 2) = mainWorkBook.Sheets("Sheet1").Range("F7").Value
arrMatrix(2, 1, 2) = mainWorkBook.Sheets("Sheet1").Range("F8").Value
arrMatrix(2, 2, 2) = mainWorkBook.Sheets("Sheet1").Range("F9").Value
arrMatrix(2, 3, 2) = mainWorkBook.Sheets("Sheet1").Range("F10").Value
arrMatrix(3, 1, 2) = mainWorkBook.Sheets("Sheet1").Range("F11").Value
arrMatrix(3, 2, 2) = mainWorkBook.Sheets("Sheet1").Range("F12").Value
arrMatrix(3, 3, 2) = mainWorkBook.Sheets("Sheet1").Range("F13").Value

arrMatrix(1, 1, 3) = mainWorkBook.Sheets("Sheet1").Range("G5").Value
arrMatrix(1, 2, 3) = mainWorkBook.Sheets("Sheet1").Range("G6").Value
arrMatrix(1, 3, 3) = mainWorkBook.Sheets("Sheet1").Range("G7").Value
arrMatrix(2, 1, 3) = mainWorkBook.Sheets("Sheet1").Range("G8").Value
arrMatrix(2, 2, 3) = mainWorkBook.Sheets("Sheet1").Range("G9").Value
arrMatrix(2, 3, 3) = mainWorkBook.Sheets("Sheet1").Range("G10").Value
arrMatrix(3, 1, 3) = mainWorkBook.Sheets("Sheet1").Range("G11").Value
arrMatrix(3, 2, 3) = mainWorkBook.Sheets("Sheet1").Range("G12").Value
arrMatrix(3, 3, 3) = mainWorkBook.Sheets("Sheet1").Range("G13").Value

arrMatrix(4, 1, 1) = mainWorkBook.Sheets("Sheet1").Range("H5").Value
arrMatrix(4, 2, 1) = mainWorkBook.Sheets("Sheet1").Range("H6").Value
arrMatrix(4, 3, 1) = mainWorkBook.Sheets("Sheet1").Range("H7").Value
arrMatrix(5, 1, 1) = mainWorkBook.Sheets("Sheet1").Range("H8").Value
arrMatrix(5, 2, 1) = mainWorkBook.Sheets("Sheet1").Range("H9").Value
arrMatrix(5, 3, 1) = mainWorkBook.Sheets("Sheet1").Range("H10").Value
arrMatrix(6, 1, 1) = mainWorkBook.Sheets("Sheet1").Range("H11").Value
arrMatrix(6, 2, 1) = mainWorkBook.Sheets("Sheet1").Range("H12").Value
arrMatrix(6, 3, 1) = mainWorkBook.Sheets("Sheet1").Range("H13").Value

arrMatrix(4, 1, 2) = mainWorkBook.Sheets("Sheet1").Range("I5").Value
arrMatrix(4, 2, 2) = mainWorkBook.Sheets("Sheet1").Range("I6").Value
arrMatrix(4, 3, 2) = mainWorkBook.Sheets("Sheet1").Range("I7").Value
arrMatrix(5, 1, 2) = mainWorkBook.Sheets("Sheet1").Range("I8").Value
arrMatrix(5, 2, 2) = mainWorkBook.Sheets("Sheet1").Range("I9").Value
arrMatrix(5, 3, 2) = mainWorkBook.Sheets("Sheet1").Range("I10").Value
arrMatrix(6, 1, 2) = mainWorkBook.Sheets("Sheet1").Range("I11").Value
arrMatrix(6, 2, 2) = mainWorkBook.Sheets("Sheet1").Range("I12").Value
arrMatrix(6, 3, 2) = mainWorkBook.Sheets("Sheet1").Range("I13").Value

arrMatrix(4, 1, 3) = mainWorkBook.Sheets("Sheet1").Range("J5").Value
arrMatrix(4, 2, 3) = mainWorkBook.Sheets("Sheet1").Range("J6").Value
arrMatrix(4, 3, 3) = mainWorkBook.Sheets("Sheet1").Range("J7").Value
arrMatrix(5, 1, 3) = mainWorkBook.Sheets("Sheet1").Range("J8").Value
arrMatrix(5, 2, 3) = mainWorkBook.Sheets("Sheet1").Range("J9").Value
arrMatrix(5, 3, 3) = mainWorkBook.Sheets("Sheet1").Range("J10").Value
arrMatrix(6, 1, 3) = mainWorkBook.Sheets("Sheet1").Range("J11").Value
arrMatrix(6, 2, 3) = mainWorkBook.Sheets("Sheet1").Range("J12").Value
arrMatrix(6, 3, 3) = mainWorkBook.Sheets("Sheet1").Range("J13").Value

arrMatrix(7, 1, 1) = mainWorkBook.Sheets("Sheet1").Range("K5").Value
arrMatrix(7, 2, 1) = mainWorkBook.Sheets("Sheet1").Range("K6").Value
arrMatrix(7, 3, 1) = mainWorkBook.Sheets("Sheet1").Range("K7").Value
arrMatrix(8, 1, 1) = mainWorkBook.Sheets("Sheet1").Range("K8").Value
arrMatrix(8, 2, 1) = mainWorkBook.Sheets("Sheet1").Range("K9").Value
arrMatrix(8, 3, 1) = mainWorkBook.Sheets("Sheet1").Range("K10").Value
arrMatrix(9, 1, 1) = mainWorkBook.Sheets("Sheet1").Range("K11").Value
arrMatrix(9, 2, 1) = mainWorkBook.Sheets("Sheet1").Range("K12").Value
arrMatrix(9, 3, 1) = mainWorkBook.Sheets("Sheet1").Range("K13").Value

arrMatrix(7, 1, 2) = mainWorkBook.Sheets("Sheet1").Range("L5").Value
arrMatrix(7, 2, 2) = mainWorkBook.Sheets("Sheet1").Range("L6").Value
arrMatrix(7, 3, 2) = mainWorkBook.Sheets("Sheet1").Range("L7").Value
arrMatrix(8, 1, 2) = mainWorkBook.Sheets("Sheet1").Range("L8").Value
arrMatrix(8, 2, 2) = mainWorkBook.Sheets("Sheet1").Range("L9").Value
arrMatrix(8, 3, 2) = mainWorkBook.Sheets("Sheet1").Range("L10").Value
arrMatrix(9, 1, 2) = mainWorkBook.Sheets("Sheet1").Range("L11").Value
arrMatrix(9, 2, 2) = mainWorkBook.Sheets("Sheet1").Range("L12").Value
arrMatrix(9, 3, 2) = mainWorkBook.Sheets("Sheet1").Range("L13").Value

arrMatrix(7, 1, 3) = mainWorkBook.Sheets("Sheet1").Range("M5").Value
arrMatrix(7, 2, 3) = mainWorkBook.Sheets("Sheet1").Range("M6").Value
arrMatrix(7, 3, 3) = mainWorkBook.Sheets("Sheet1").Range("M7").Value
arrMatrix(8, 1, 3) = mainWorkBook.Sheets("Sheet1").Range("M8").Value
arrMatrix(8, 2, 3) = mainWorkBook.Sheets("Sheet1").Range("M9").Value
arrMatrix(8, 3, 3) = mainWorkBook.Sheets("Sheet1").Range("M10").Value
arrMatrix(9, 1, 3) = mainWorkBook.Sheets("Sheet1").Range("M11").Value
arrMatrix(9, 2, 3) = mainWorkBook.Sheets("Sheet1").Range("M12").Value
arrMatrix(9, 3, 3) = mainWorkBook.Sheets("Sheet1").Range("M13").Value

End Function

Function FnFillValues()
'intChar = 69
'j = 1
'Set mainWorkBook = ActiveWorkbook
'For k = 1 To 9
'   For m = 69 To 77
'      For k = 1 To 3
'          For i = 1 To 3
'             arrMatrix(k, i, j) = mainWorkBook.Sheets("Sheet1").Range(Chr(m) & i + 4).Value
'        Next
'       j = j + 1
'  Next
'Next
'Next

mainWorkBook.Sheets("Sheet1").Range("E5").Value = arrMatrix(1, 1, 1)
mainWorkBook.Sheets("Sheet1").Range("E6").Value = arrMatrix(1, 2, 1)
mainWorkBook.Sheets("Sheet1").Range("E7").Value = arrMatrix(1, 3, 1)
mainWorkBook.Sheets("Sheet1").Range("E8").Value = arrMatrix(2, 1, 1)
mainWorkBook.Sheets("Sheet1").Range("E9").Value = arrMatrix(2, 2, 1)
mainWorkBook.Sheets("Sheet1").Range("E10").Value = arrMatrix(2, 3, 1)
mainWorkBook.Sheets("Sheet1").Range("E11").Value = arrMatrix(3, 1, 1)
mainWorkBook.Sheets("Sheet1").Range("E12").Value = arrMatrix(3, 2, 1)
mainWorkBook.Sheets("Sheet1").Range("E13").Value = arrMatrix(3, 3, 1)

mainWorkBook.Sheets("Sheet1").Range("F5").Value = arrMatrix(1, 1, 2)
mainWorkBook.Sheets("Sheet1").Range("F6").Value = arrMatrix(1, 2, 2)
mainWorkBook.Sheets("Sheet1").Range("F7").Value = arrMatrix(1, 3, 2)
mainWorkBook.Sheets("Sheet1").Range("F8").Value = arrMatrix(2, 1, 2)
mainWorkBook.Sheets("Sheet1").Range("F9").Value = arrMatrix(2, 2, 2)
mainWorkBook.Sheets("Sheet1").Range("F10").Value = arrMatrix(2, 3, 2)
mainWorkBook.Sheets("Sheet1").Range("F11").Value = arrMatrix(3, 1, 2)
mainWorkBook.Sheets("Sheet1").Range("F12").Value = arrMatrix(3, 2, 2)
mainWorkBook.Sheets("Sheet1").Range("F13").Value = arrMatrix(3, 3, 2)

mainWorkBook.Sheets("Sheet1").Range("G5").Value = arrMatrix(1, 1, 3)
mainWorkBook.Sheets("Sheet1").Range("G6").Value = arrMatrix(1, 2, 3)
mainWorkBook.Sheets("Sheet1").Range("G7").Value = arrMatrix(1, 3, 3)
mainWorkBook.Sheets("Sheet1").Range("G8").Value = arrMatrix(2, 1, 3)
mainWorkBook.Sheets("Sheet1").Range("G9").Value = arrMatrix(2, 2, 3)
mainWorkBook.Sheets("Sheet1").Range("G10").Value = arrMatrix(2, 3, 3)
mainWorkBook.Sheets("Sheet1").Range("G11").Value = arrMatrix(3, 1, 3)
mainWorkBook.Sheets("Sheet1").Range("G12").Value = arrMatrix(3, 2, 3)
mainWorkBook.Sheets("Sheet1").Range("G13").Value = arrMatrix(3, 3, 3)

mainWorkBook.Sheets("Sheet1").Range("H5").Value = arrMatrix(4, 1, 1)
mainWorkBook.Sheets("Sheet1").Range("H6").Value = arrMatrix(4, 2, 1)
mainWorkBook.Sheets("Sheet1").Range("H7").Value = arrMatrix(4, 3, 1)
mainWorkBook.Sheets("Sheet1").Range("H8").Value = arrMatrix(5, 1, 1)
mainWorkBook.Sheets("Sheet1").Range("H9").Value = arrMatrix(5, 2, 1)
mainWorkBook.Sheets("Sheet1").Range("H10").Value = arrMatrix(5, 3, 1)
mainWorkBook.Sheets("Sheet1").Range("H11").Value = arrMatrix(6, 1, 1)
mainWorkBook.Sheets("Sheet1").Range("H12").Value = arrMatrix(6, 2, 1)
mainWorkBook.Sheets("Sheet1").Range("H13").Value = arrMatrix(6, 3, 1)

mainWorkBook.Sheets("Sheet1").Range("I5").Value = arrMatrix(4, 1, 2)
mainWorkBook.Sheets("Sheet1").Range("I6").Value = arrMatrix(4, 2, 2)
mainWorkBook.Sheets("Sheet1").Range("I7").Value = arrMatrix(4, 3, 2)
mainWorkBook.Sheets("Sheet1").Range("I8").Value = arrMatrix(5, 1, 2)
mainWorkBook.Sheets("Sheet1").Range("I9").Value = arrMatrix(5, 2, 2)
mainWorkBook.Sheets("Sheet1").Range("I10").Value = arrMatrix(5, 3, 2)
mainWorkBook.Sheets("Sheet1").Range("I11").Value = arrMatrix(6, 1, 2)
mainWorkBook.Sheets("Sheet1").Range("I12").Value = arrMatrix(6, 2, 2)
mainWorkBook.Sheets("Sheet1").Range("I13").Value = arrMatrix(6, 3, 2)

mainWorkBook.Sheets("Sheet1").Range("J5").Value = arrMatrix(4, 1, 3)
mainWorkBook.Sheets("Sheet1").Range("J6").Value = arrMatrix(4, 2, 3)
mainWorkBook.Sheets("Sheet1").Range("J7").Value = arrMatrix(4, 3, 3)
mainWorkBook.Sheets("Sheet1").Range("J8").Value = arrMatrix(5, 1, 3)
mainWorkBook.Sheets("Sheet1").Range("J9").Value = arrMatrix(5, 2, 3)
mainWorkBook.Sheets("Sheet1").Range("J10").Value = arrMatrix(5, 3, 3)
mainWorkBook.Sheets("Sheet1").Range("J11").Value = arrMatrix(6, 1, 3)
mainWorkBook.Sheets("Sheet1").Range("J12").Value = arrMatrix(6, 2, 3)
mainWorkBook.Sheets("Sheet1").Range("J13").Value = arrMatrix(6, 3, 3)

mainWorkBook.Sheets("Sheet1").Range("K5").Value = arrMatrix(7, 1, 1)
mainWorkBook.Sheets("Sheet1").Range("K6").Value = arrMatrix(7, 2, 1)
mainWorkBook.Sheets("Sheet1").Range("K7").Value = arrMatrix(7, 3, 1)
mainWorkBook.Sheets("Sheet1").Range("K8").Value = arrMatrix(8, 1, 1)
mainWorkBook.Sheets("Sheet1").Range("K9").Value = arrMatrix(8, 2, 1)
mainWorkBook.Sheets("Sheet1").Range("K10").Value = arrMatrix(8, 3, 1)
mainWorkBook.Sheets("Sheet1").Range("K11").Value = arrMatrix(9, 1, 1)
mainWorkBook.Sheets("Sheet1").Range("K12").Value = arrMatrix(9, 2, 1)
mainWorkBook.Sheets("Sheet1").Range("K13").Value = arrMatrix(9, 3, 1)

mainWorkBook.Sheets("Sheet1").Range("L5").Value = arrMatrix(7, 1, 2)
mainWorkBook.Sheets("Sheet1").Range("L6").Value = arrMatrix(7, 2, 2)
mainWorkBook.Sheets("Sheet1").Range("L7").Value = arrMatrix(7, 3, 2)
mainWorkBook.Sheets("Sheet1").Range("L8").Value = arrMatrix(8, 1, 2)
mainWorkBook.Sheets("Sheet1").Range("L9").Value = arrMatrix(8, 2, 2)
mainWorkBook.Sheets("Sheet1").Range("L10").Value = arrMatrix(8, 3, 2)
mainWorkBook.Sheets("Sheet1").Range("L11").Value = arrMatrix(9, 1, 2)
mainWorkBook.Sheets("Sheet1").Range("L12").Value = arrMatrix(9, 2, 2)
mainWorkBook.Sheets("Sheet1").Range("L13").Value = arrMatrix(9, 3, 2)

mainWorkBook.Sheets("Sheet1").Range("M5").Value = arrMatrix(7, 1, 3)
mainWorkBook.Sheets("Sheet1").Range("M6").Value = arrMatrix(7, 2, 3)
mainWorkBook.Sheets("Sheet1").Range("M7").Value = arrMatrix(7, 3, 3)
mainWorkBook.Sheets("Sheet1").Range("M8").Value = arrMatrix(8, 1, 3)
mainWorkBook.Sheets("Sheet1").Range("M9").Value = arrMatrix(8, 2, 3)
mainWorkBook.Sheets("Sheet1").Range("M10").Value = arrMatrix(8, 3, 3)
mainWorkBook.Sheets("Sheet1").Range("M11").Value = arrMatrix(9, 1, 3)
mainWorkBook.Sheets("Sheet1").Range("M12").Value = arrMatrix(9, 2, 3)
mainWorkBook.Sheets("Sheet1").Range("M13").Value = arrMatrix(9, 3, 3)

End Function

Private Sub btnUpdateCompanyName_Click()
    Dim accApp As Access.Application
    Dim strNewCompanyName As String
    Dim obj As AccessObject
    Dim ctl As Control
    Dim dbPath As String

    On Error GoTo ErrorHandler
    
    ' Get the new company name from the text box and handle Null value
    strNewCompanyName = Nz(Me.txtCompanyName.Value, "")

    ' Check if the text box is empty
    If Trim(strNewCompanyName) = "" Then
        MsgBox "Please enter the new company name.", vbExclamation
        Exit Sub
    End If

    ' Construct the relative path to the other database
    dbPath = CurrentProject.Path & "\Sales.accdb"

    ' Check if the other database is already open
    If IsDatabaseOpen(dbPath) Then
        MsgBox "The database is already open. Please close it before running this operation.", vbExclamation
        Exit Sub
    End If

    ' Open the other database
    Set accApp = New Access.Application
    accApp.OpenCurrentDatabase (dbPath)

    ' Loop through all forms
    For Each obj In accApp.CurrentProject.AllForms
        accApp.DoCmd.OpenForm obj.Name, acDesign
        For Each ctl In accApp.Forms(obj.Name).Controls
            If ctl.ControlType = acLabel And ctl.Name = "Label1" Then
                ctl.Caption = strNewCompanyName
            End If
        Next ctl
        accApp.DoCmd.Close acForm, obj.Name, acSaveYes
    Next obj

    ' Loop through all reports
    For Each obj In accApp.CurrentProject.AllReports
        accApp.DoCmd.OpenReport obj.Name, acViewDesign
        For Each ctl In accApp.Reports(obj.Name).Controls
            If ctl.ControlType = acLabel And ctl.Name = "Label1" Then
                ctl.Caption = strNewCompanyName
            End If
        Next ctl
        accApp.DoCmd.Close acReport, obj.Name, acSaveYes
    Next obj

    ' Close the other database
    accApp.CloseCurrentDatabase
    accApp.Quit
    Set accApp = Nothing

    ' Notify user
    MsgBox "Company name updated successfully!"

    Exit Sub

ErrorHandler:
    If Not accApp Is Nothing Then
        accApp.CloseCurrentDatabase
        accApp.Quit
        Set accApp = Nothing
    End If
    MsgBox "An error occurred: " & Err.Description, vbCritical

End Sub

Sub RemoveEmptyLines()
    Dim para As Paragraph
    For Each para In ActiveDocument.Paragraphs
        If Len(para.Range.Text) <= 1 Then
            para.Range.Delete
        End If
    Next para
End Sub
Sub RemoveDuplicatesAndKeepLatest()
    Dim ws As Worksheet
    Set ws = [thisworkbook](/activeworkbook-thisworkbook/).Sheets("YourSheetName") ' Assign [Worksheet](/vba/sheets-worksheets) object to "ws". Replace "YourSheetName" with the actual sheet name

    ' Assuming Column D contains the timestamp
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row  ' Find the last row in the worksheet

    ' Perform sort operation based on columns 1,3 and timestamp in Column D (adjust accordingly)
    With ws.Sort
        .SortFields.Clear  
        .SortFields.Add Key:=ws.Range("A2:A" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal   ' Sort on column A ascendingly
        .SortFields.Add Key:=ws.Range("C2:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal   ' Sort on column C ascendingly
        .SortFields.Add Key:=ws.Range("D2:D" & lastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal  ' Sort on column D descendingly (to keep the latest)
        .SetRange ws.Range("A1:AD" & lastRow) 
        .Header = xlYes  
        .MatchCase = False  
        .Orientation = xlTopToBottom  
        .SortMethod = xlPinYin  
        .Apply  ' Apply the sorting to the range
    End With

    ' Loop through the sorted range and remove duplicates, keeping the latest occurrence
    Dim currentRow As Long
    For currentRow = lastRow To 3 Step -1 ' Loop from the bottom of sheet to the top
        If ws.Cells(currentRow, 1).Value = ws.Cells(currentRow - 1, 1).Value And _
           ws.Cells(currentRow, 3).Value = ws.Cells(currentRow - 1, 3).Value Then
            ' If corresponding cells in Column A and Column C are identical, delete the current row
            ws.Rows(currentRow).Delete  ' Delete the row
        End If
    Next currentRow
End Sub
SELECT

  LEFT(CONVERT(varchar,[REQ ITEM CHECKIN DATETIME], 120),16) as วันที่รับแล็บ
     ,LEFT(CONVERT(varchar,[ORDER DATETIME], 120),16) as วันที่สั่ง
     ,[HN]
     ,[LN]
     ,[FULLNAME] as [ชื่อ-สกุล]
     ,[YEAR] as ปี
     ,[SEX] as เพศ
     ,[WARD NAME] as จุดที่สั่ง
     ,[REQ ITEM GROUP CODE] as CODE
     ,[RES ITEM NAME] as รายการตรวจ
     ,[RES ITEM RESULT] as ผลการตรวจ
     ,[RES ITEM STATE] as state
     ,[ORDER COMMENT] as comment



  FROM [LAB_DB].[dbo].[view_lab_statistic_Result_List]

WHERE 
  [ORDER INACTIVE] ='n' 
     AND ([REQ ITEM GROUP CODE] ='SP' or [REQ ITEM GROUP CODE] ='PA')
     AND ([REQ STATE] ='a' or [REQ STATE] ='u')
	 
	 
	 --[REQ ITEM CHECKIN DATETIME]
	 --Checkin
CASE WHEN "%CH201%" = "<10" AND "%CH202%" = "<10" THEN "<30"
     WHEN "%CH201%" = "<10" AND "%CH202%" <> "" THEN "<30" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "<10" THEN "50"    
     WHEN "%CH201%" = "10" AND "%CH202%" = "10" THEN "100" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "50" THEN "20" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "100" THEN "10" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "200" THEN "5" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "300" THEN "3" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = ">300" THEN "<30" 
	 WHEN "%CH201%" = "30" AND "%CH202%" = "<10" THEN "150" 
	 WHEN "%CH201%" = "30" AND "%CH202%" = "10" THEN "300" 
	 WHEN "%CH201%" = "30" AND "%CH202%" = "50" THEN "60" 
	 WHEN "%CH201%" = "30" AND "%CH202%" = "100" THEN "30"
	 WHEN "%CH201%" = "30" AND "%CH202%" = "200" THEN "15"
	 WHEN "%CH201%" = "30" AND "%CH202%" = "300" THEN "10"
	 WHEN "%CH201%" = "30" AND "%CH202%" = ">300" THEN "<30"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "<10" THEN ">300"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "10" THEN ">300"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "50" THEN "160"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "100" THEN "80"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "200" THEN "40"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "300" THEN "27"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "<30" THEN "<30"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "<10" THEN ">300"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "10" THEN ">300"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "50" THEN "300"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "100" THEN "150"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "200" THEN "75"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "300" THEN "50"
	 WHEN "%CH201%" = "150" AND "%CH202%" = ">300" THEN "<30"
	 WHEN "%CH201%" = ">150" AND "%CH202%" <> "" THEN ">300"
 ELSE "N/A" END
 [SOURCE CODE]

[WARD]

[PRIORITY]

[PATIENT TYPE CODE]

[YEAR]

[SEX]

[REQ ITEM ORDER DATETIME]
declare @value decimal(10,2)
set @value = (select 
CASE WHEN %CH003% = 0 THEN 0 
WHEN {AGE,YEAR} > 130.0 THEN 0 
WHEN {AGE,YEAR} < 18.0 THEN ((0.41 * {HEIGHT}) / %CH003%) 
WHEN {SEX} = "M" AND %CH003% <= 0.9 THEN ((141 * (POWER((%CH003% / 0.9), -0.411))) * POWER(0.993, {AGE,YEAR})) 
WHEN {SEX} = "M" AND %CH003% > 0.9 THEN ((141 * (POWER((%CH003% / 0.9), -1.209))) * POWER(0.993, {AGE,YEAR})) 
WHEN {SEX} = "F" AND %CH003% <= 0.7 THEN ((144 * (POWER((%CH003% / 0.7), -0.329))) * POWER(0.993, {AGE,YEAR})) 
WHEN {SEX} = "F" AND %CH003% > 0.7 THEN ((144 * (POWER((%CH003% / 0.7), -1.209))) * POWER(0.993, {AGE,YEAR})) ELSE 0 END)

SELECT CASE WHEN @value > 90.0 THEN "Stage G1"      
WHEN @value >= 60.00 AND @value <= 89.99 THEN "Stage G2"      
WHEN @value >= 45.00 AND @value <= 59.99 THEN "Stage G3a"      
WHEN @value >= 30.00 AND @value <= 44.99 THEN "Stage G3b"      
WHEN @value >= 15.00 AND @value <= 29.99 THEN "Stage G4"      
WHEN @value <  15.00 THEN "Stage G5"      
ELSE "N/A" END
taskkill /F /IM  I-CN-HIS.exe /T


D:

cd  D:\LisInterface\HIS\i-CN-HIS XML

start i-CN-HIS.exe
//เด็กคอม www.dek-com.com

const ACCESS_TOKEN = "ACCESS_TOKEN";

const bot = new LineBotSdk.client(ACCESS_TOKEN);

function doPost(e) { bot.call(e, callback) };

function callback(e) {

  if (e.message.type == "text" ) {

     bot.replyMessage(e, [bot.textMessage(bard(e.message.text, 'en', 'th'))]);

  }

};

//เด็กคอม www.dek-com.com

function bard(prompt) {

  var promptEN = LanguageApp.translate(prompt, 'th', 'en'); // เพิ่มจุดที่ 1

  var api_key = "API KEY"; //bard2 api

  var url = "https://generativelanguage.googleapis.com/v1beta2/models/text-bison-001:generateText?key=" + api_key;

  var headers = {

    "Content-Type": "application/json"

  };

  var requestBody = {

    "prompt": {

    "text": promptEN

    }

  }

  

  var options = {

    "method" : "POST",

    "headers": headers,

    "payload": JSON.stringify(requestBody)

  }

  var response = UrlFetchApp.fetch(url,options);

  var data = JSON.parse(response.getContentText());

  var output = data.candidates[0].output;

  return  LanguageApp.translate(output, 'en', 'th'); // เพิ่มจุดที่ 2

}

//เด็กคอม www.dek-com.comDepoy ใหม่ด้วยนะครับ 😊

//เด็กคอม www.dek-com.com

const ACCESS_TOKEN = "ACCESS_TOKEN";

const bot = new LineBotSdk.client(ACCESS_TOKEN);

function doPost(e) { bot.call(e, callback) };

function callback(e) {

  if (e.message.type == "text" ) {

     bot.replyMessage(e, [bot.textMessage(bard(e.message.text, 'en', 'th'))]);

  }

};

//เด็กคอม www.dek-com.com

function bard(prompt) {

  var promptEN = LanguageApp.translate(prompt, 'th', 'en'); // เพิ่มจุดที่ 1

  var api_key = "API KEY"; //bard2 api

  var url = "https://generativelanguage.googleapis.com/v1beta2/models/text-bison-001:generateText?key=" + api_key;

  var headers = {

    "Content-Type": "application/json"

  };

  var requestBody = {

    "prompt": {

    "text": promptEN

    }

  }

  

  var options = {

    "method" : "POST",

    "headers": headers,

    "payload": JSON.stringify(requestBody)

  }

  var response = UrlFetchApp.fetch(url,options);

  var data = JSON.parse(response.getContentText());

  var output = data.candidates[0].output;

  return  LanguageApp.translate(output, 'en', 'th'); // เพิ่มจุดที่ 2

}

//เด็กคอม www.dek-com.com
Sub invoiceConcat()

''工作表名稱
Const kWSName As String = "工作表2"
''使用範圍列數
Dim kRow As Integer
''外層For迴圈計數器
Dim kCNT As Integer
''內層For迴圈計數器
Dim kCounter As Integer
''用來當作索引的發票號碼
Dim kTarget As String
''發票明細
Dim kDetail As String

ThisWorkbook.Worksheets(kWSName).Select

With ActiveSheet
''取得最後一列列號
    kRow = .Range("A65536").End(xlUp).Row
    
    For kCNT = 3 To kRow
    ''發票號碼
        kTarget = .Cells(kCNT, 7)
        
        For kCounter = 1 To kRow
            If .Cells(kCounter, 2) = kTarget Then
                ''可自己設定所需的明細格式
                kDetail = kDetail & Trim(.Cells(kCounter, 4)) & " [NT$ " & .Cells(kCounter, 3) & "]" & Chr(13)
            End If
        Next kCounter
        
        ''刪除句尾多的一個換行符號
        If kDetail <> "" Then
            .Cells(kCNT, 10) = Mid(kDetail, 1, Len(kDetail) - 1)
        End If
        ''明細字串重置
        kDetail = ""
    Next kCNT
End With

End Sub
UPDATE dbo.tbl_lab_setup_Source_Definition
SET Source_Definition_Name = CASE

			WHEN Source_Definition_Code = '000'	  THEN		'ไม่ทราบฝ่าย'
			WHEN Source_Definition_Code = '001'   THEN      'ความดัน'
			WHEN Source_Definition_Code = '002'   THEN      'เบาหวาน'
			WHEN Source_Definition_Code = '003'   THEN      'โรคปอด'
			WHEN Source_Definition_Code = '004'   THEN      'จุดซักประวัติ VIP'
			WHEN Source_Definition_Code = '005'   THEN      'ฝ่ายทันตสาธารณสุข'
			WHEN Source_Definition_Code = '006'   THEN      'หน้าห้องฉุกเฉิน'
			WHEN Source_Definition_Code = '007'   THEN      'ห้อง LAB'
			WHEN Source_Definition_Code = '008'   THEN      'ฝ่าย Computer'
			WHEN Source_Definition_Code = '009'   THEN      'ตึกผู้ป่วยใน'
			WHEN Source_Definition_Code = '010'   THEN      'จุดซักประวัติOPD1'
			WHEN Source_Definition_Code = '011'   THEN      'ห้อง Emergency Room (ER)'
			WHEN Source_Definition_Code = '012'   THEN      'ฝ่าย X-Ray'
			WHEN Source_Definition_Code = '013'   THEN      'ฝ่ายเวชระเบียน'
			WHEN Source_Definition_Code = '014'   THEN      'ห้องตรวจโรค'
			WHEN Source_Definition_Code = '015'   THEN      'CUPS'
			WHEN Source_Definition_Code = '016'   THEN      'ห้องจ่ายเงินผู้ป่วยนอก'
			WHEN Source_Definition_Code = '017'   THEN      'ห้องคลอด'
			WHEN Source_Definition_Code = '018'   THEN      'ห้องจ่ายกลาง'
			WHEN Source_Definition_Code = '019'   THEN      'ห้องตรวจโรค1'
			WHEN Source_Definition_Code = '020'   THEN      'ห้องตรวจโรค2'
			WHEN Source_Definition_Code = '021'   THEN      'ห้องตรวจโรค 3'
			WHEN Source_Definition_Code = '022'   THEN      'ห้องงานสุขศึกษาประชาสัมพันธ์'
			WHEN Source_Definition_Code = '023'   THEN      'จุดชักประวัติ ARV'
			WHEN Source_Definition_Code = '024'   THEN      'โรงครัว'
			WHEN Source_Definition_Code = '025'   THEN      'ห้องทำหัตถการผู้ป่วยนอก'
			WHEN Source_Definition_Code = '026'   THEN      'จุดซักประวัติOPD2'
			WHEN Source_Definition_Code = '027'   THEN      'ห้องตรวจโรค 4'
			WHEN Source_Definition_Code = '028'   THEN      'ห้องตรวจโรค 5'
			WHEN Source_Definition_Code = '029'   THEN      'ห้องตรวจโรค 6'
			WHEN Source_Definition_Code = '030'   THEN      'ห้องจ่ายยาผู้ป่วยนอก'
			WHEN Source_Definition_Code = '031'   THEN      'จุดเรียกคิวสูตินารีเวช'
			WHEN Source_Definition_Code = '032'   THEN      'ห้องตรวจสูตินารีเวช'
			WHEN Source_Definition_Code = '033'   THEN      'ห้องตรวจโรคหัวใจ'
			WHEN Source_Definition_Code = '034'   THEN      'ห้องตรวจสุขภาพเด็กดี'
			WHEN Source_Definition_Code = '035'   THEN      'งานป้องกันโรค'
			WHEN Source_Definition_Code = '036'   THEN      'ห้องตรวจครรภ์'
			WHEN Source_Definition_Code = '037'   THEN      'ห้องตรวจจิตเวช'
			WHEN Source_Definition_Code = '038'   THEN      'NB (ทารกแรกเกิด)'
			WHEN Source_Definition_Code = '039'   THEN      'ห้องตรวจโรค7'
			WHEN Source_Definition_Code = '040'   THEN      'ห้องฉีดยา'
			WHEN Source_Definition_Code = '041'   THEN      'แพทย์แผนไทย'
			WHEN Source_Definition_Code = '042'   THEN      'กายภาพบำบัด'
			WHEN Source_Definition_Code = '043'   THEN      'Asthma'
			WHEN Source_Definition_Code = '044'   THEN      'ห้องตรวจโรค9'
			WHEN Source_Definition_Code = '045'   THEN      'ห้องตรวจโรค ARV'
			WHEN Source_Definition_Code = '046'   THEN      'HHC'
			WHEN Source_Definition_Code = '047'   THEN      'วัยทอง'
			WHEN Source_Definition_Code = '048'   THEN      'ฝ่ายส่งเสริมสุขภาพ'
			WHEN Source_Definition_Code = '049'   THEN      'ห้องตรวจโรค10'
			WHEN Source_Definition_Code = '050'   THEN      'จุดเรียกคิวคลีกนิคพิเศษ'
			WHEN Source_Definition_Code = '051'   THEN      'จุดเรียกคิว OPD'
			WHEN Source_Definition_Code = '052'   THEN      'Exit Nurse'
			WHEN Source_Definition_Code = '053'   THEN      'ห้องฟ้าใส'
			WHEN Source_Definition_Code = '054'   THEN      'ห้องผ่าตัด'
			WHEN Source_Definition_Code = '055'   THEN      'ห้องตรวจโรค8'
			WHEN Source_Definition_Code = '056'   THEN      'จุดซักประวัติตรวจสุขภาพประจำปี'
			WHEN Source_Definition_Code = '057'   THEN      'คลินิกผู้สูงอายุ'
			WHEN Source_Definition_Code = '058'   THEN      'ห้องจ่ายยาคลินิกพิเศษ'
			WHEN Source_Definition_Code = '059'   THEN      'ห้องตรวจธาลัสซีเมียในเด็ก'
			WHEN Source_Definition_Code = '060'   THEN      'คลิกนิคไข้หวัด'
			WHEN Source_Definition_Code = '061'   THEN      'Bloodbank'
			WHEN Source_Definition_Code = '062'   THEN      'จุดซักประวัติกุมารเวชกรรม'
			WHEN Source_Definition_Code = '063'   THEN      'จุดเรียกคิวกุมารเวชกรรม'
			WHEN Source_Definition_Code = '064'   THEN      'ห้องอัลตราชาวด์'
			WHEN Source_Definition_Code = '065'   THEN      'ห้องตรวจคลินิกพิเศษ1'
			WHEN Source_Definition_Code = '066'   THEN      'ห้องตรวจคลินิกพิเศษ2'
			WHEN Source_Definition_Code = '067'   THEN      'ห้องตรวจคลินิกพิเศษ3'
			WHEN Source_Definition_Code = '068'   THEN      'ห้องตรวจคลินิกพิเศษ4'
			WHEN Source_Definition_Code = '069'   THEN      'ห้องตรวจคลินิกพิเศษ5'
			WHEN Source_Definition_Code = '070'   THEN      'ห้องตรวจคลินิกพิเศษ6'
			WHEN Source_Definition_Code = '071'   THEN      'ห้องตรวจคลินิกพิเศษ7'
			WHEN Source_Definition_Code = '072'   THEN      'ห้องตรวจคลินิกพิเศษ8'
			WHEN Source_Definition_Code = '073'   THEN      'จุดเรียกคิวเบาหวาน+ความดัน'
			WHEN Source_Definition_Code = '074'   THEN      'จุดซักประวัติผู้ป่วยนอก2(ผู้ป่วยนัด)'
			WHEN Source_Definition_Code = '075'   THEN      'จุดซักประวัติผู้ป่วยนอก3(ผู้ป่วยมีไข้)'
			WHEN Source_Definition_Code = '076'   THEN      'คลินิกลดพุง'
			WHEN Source_Definition_Code = '077'   THEN      'จุดเรียกคิวผู้สูงอายุ'
			WHEN Source_Definition_Code = '078'   THEN      'Teen friendly'
			WHEN Source_Definition_Code = '079'   THEN      'ห้องตรวจส่งเสริม'
			WHEN Source_Definition_Code = '080'   THEN      'ตึกเด็ก'
			WHEN Source_Definition_Code = '081'   THEN      'ตึกชาย'
			WHEN Source_Definition_Code = '082'   THEN      'ตึกหญิง'
			WHEN Source_Definition_Code = '083'   THEN      'ตึกสูติ-นารีเวช'
			WHEN Source_Definition_Code = '084'   THEN      'ตึกศัลยกรรม'
			WHEN Source_Definition_Code = '085'   THEN      'จุดเรียกคิวศัลยกรรม'
			WHEN Source_Definition_Code = '086'   THEN      'จุดเรียกคิวศัลยกรรมเด็ก'
			WHEN Source_Definition_Code = '087'   THEN      '70 ปีไม่มีคิว'
			WHEN Source_Definition_Code = '088'   THEN      'ห้องวางแผนครอบครัว'
			WHEN Source_Definition_Code = '089'   THEN      'โรคเรื้อรัง'
			WHEN Source_Definition_Code = '090'   THEN      'ห้องตรวจผู้ป่วยCAPD'
			WHEN Source_Definition_Code = '091'   THEN      'ห้องตรวจผู้ป่วยHD'
			WHEN Source_Definition_Code = '092'   THEN      'จุดซักประวัติไตวายเรื้อรัง'
			WHEN Source_Definition_Code = '093'   THEN      'คลินิคพบแพทย์ส่งเสริม'
			WHEN Source_Definition_Code = '094'   THEN      'คลินิคWarfarin'
			WHEN Source_Definition_Code = '095'   THEN      'กลุ่มเสี่ยง-ทางเดินหายใจ'
			WHEN Source_Definition_Code = '096'   THEN      'ศัลยกรรมกระดูก'
			WHEN Source_Definition_Code = '097'   THEN      'ตึกผู้ป่วยพิเศษชั้น6'
			WHEN Source_Definition_Code = '098'   THEN      'จุดซักประวัติธาลัสซีเมียเด็ก'
			WHEN Source_Definition_Code = '099'   THEN      'คลินิกฝังเข็ม'
			WHEN Source_Definition_Code = '100'   THEN      'ERเสริม'
			WHEN Source_Definition_Code = '101'   THEN      'ตึกศัลยกรรมกระดูก'
			WHEN Source_Definition_Code = '102'   THEN      'ตึกICU'
			WHEN Source_Definition_Code = '103'   THEN      'ห้องผ่าตัดเล็ก'
			WHEN Source_Definition_Code = '104'   THEN      'จุดเรียกคิวConsultนอกเวลา'
			WHEN Source_Definition_Code = '105'   THEN      'ห้องให้คำปรึกษา'
			WHEN Source_Definition_Code = '106'   THEN      'ตึกCOHORT'
			WHEN Source_Definition_Code = '107'   THEN      'คลิกนิกARI'
			WHEN Source_Definition_Code = '108'   THEN      'ARI ศูนย์พักคอย'
			WHEN Source_Definition_Code = '109'   THEN      'ห้องตรวจARI'
			WHEN Source_Definition_Code = '110'   THEN      'คลินิกกัญชา(พฤหัสบดี)'
			WHEN Source_Definition_Code = '111'   THEN      'ตึกผู้ป่วยพิเศษชั้น5'
			WHEN Source_Definition_Code = '112'   THEN      'จุดซักประวัติortho'
			WHEN Source_Definition_Code = '113'   THEN      'คลินิควัคซีน Covid 19'
			WHEN Source_Definition_Code = '114'   THEN      'ห้องตรวจเบาหวาน'
			WHEN Source_Definition_Code = '115'   THEN      'ห้องตรวจความดันโลหิตสูง'
			WHEN Source_Definition_Code = '116'   THEN      'ห้องตรวจโรคไตวายเรื้อรัง'
			WHEN Source_Definition_Code = '117'   THEN      'จุดซักประวัติCAPD'
			WHEN Source_Definition_Code = '118'   THEN      'จุดซักประวัติPalliative Care'
			WHEN Source_Definition_Code = '119'   THEN      'ห้องจ่ายยาTeleMedicine'
			WHEN Source_Definition_Code = '120'   THEN      'ตึกCOHORT2(ICUเก่า)'
			WHEN Source_Definition_Code = '121'   THEN      'ตึกCOHORT3(ชั้น6)'
			WHEN Source_Definition_Code = '122'   THEN      'ห้องยาศูนย์พักคอย'
			WHEN Source_Definition_Code = '123'   THEN      'ห้องจ่ายยา NCD'
			WHEN Source_Definition_Code = '124'   THEN      'ห้องจ่ายเงิน NCD'
			WHEN Source_Definition_Code = '125'   THEN      'ห้องจ่ายยาผู้ป่วยใน'
			WHEN Source_Definition_Code = '126'   THEN      'จุดซักประวัติคลินิควัคซีนCovid 19'
			WHEN Source_Definition_Code = '127'   THEN      'จุดซักประวัติ Self Isolation'
			WHEN Source_Definition_Code = '128'   THEN      'ห้องตรวจ Self Isolation'
			WHEN Source_Definition_Code = '129'   THEN      'จุดซักประวัติ Home Isolation'
			WHEN Source_Definition_Code = '130'   THEN      'ห้องตรวจ Home Isolation'
			WHEN Source_Definition_Code = '131'   THEN      'ห้องจำหน่ายผู้ป่วย Home Isolatio'
			WHEN Source_Definition_Code = '132'   THEN      'จุดซักประวัติERบ่ายเสริม'
			WHEN Source_Definition_Code = '133'   THEN      'ห้องตรวจสุขภาพจิตเด็กและวัยรุ่น'
			WHEN Source_Definition_Code = '134'   THEN      'จุดซักประวัติสุขภาพจิต'
			WHEN Source_Definition_Code = '135'   THEN      'จุดซักประวัติฝากครรภ์'
			WHEN Source_Definition_Code = '136'   THEN      'ห้องให้คำปรึกษาสุขภาพจิต'
			WHEN Source_Definition_Code = '137'   THEN      'ห้องรอฉีดยา'
			WHEN Source_Definition_Code = '138'   THEN      'ห้องตรวจพัฒนาการเด็ก'
			WHEN Source_Definition_Code = '139'   THEN      'CTscan'
			WHEN Source_Definition_Code = '999'   THEN      'กลับบ้าน'
			WHEN Source_Definition_Code = '01'    THEN      'ตึกชาย'
			WHEN Source_Definition_Code = '02'    THEN      'ตึกหญิง'
			WHEN Source_Definition_Code = '03'    THEN      'ตึกเด็ก'
			WHEN Source_Definition_Code = '05'    THEN      'ตึกคลอด'
			WHEN Source_Definition_Code = '06'    THEN      'ตึกผู้ป่วยพิเศษชั้น6'
			WHEN Source_Definition_Code = '07'    THEN      'ตึกสูติ-นารีเวช'
			WHEN Source_Definition_Code = '08'    THEN      'ตึกศัลยกรรม'
			WHEN Source_Definition_Code = '09'    THEN      'ตึกศัลยกรรมกระดูก'
			WHEN Source_Definition_Code = '10'    THEN      'ตึกICU'
			WHEN Source_Definition_Code = '11'    THEN      'ตึกติดเชื้อ'
			WHEN Source_Definition_Code = '12'    THEN      'ตึกผู้ป่วยพิเศษชั้น5'
			WHEN Source_Definition_Code = '13'    THEN      'ตึกCOHORT3(ชั้น6)'
			WHEN Source_Definition_Code = '14'    THEN      'ตึกCOHORT2(ICUเก่า)'
			WHEN Source_Definition_Code = '15'    THEN      'CIสังขะ_HI'
			WHEN Source_Definition_Code = '16'    THEN      'CIกระเทียม_KT'
			WHEN Source_Definition_Code = '17'    THEN      'CIทับทัน_TA'
			WHEN Source_Definition_Code = '18'    THEN      'CIเทพรักษา_TR'
			WHEN Source_Definition_Code = '19'    THEN      'CIขอนแตก_KK'
			WHEN Source_Definition_Code = '20'    THEN      'CIพระแก้ว_PK'
			WHEN Source_Definition_Code = '21'    THEN      'CIดม_DM'
			WHEN Source_Definition_Code = '22'    THEN      'CIสะกาด_SK'
			WHEN Source_Definition_Code = '23'    THEN      'CIตาคง_TK'
			WHEN Source_Definition_Code = '24'    THEN      'CIตาตุม+ตาแตรว_TT'
			WHEN Source_Definition_Code = '25'    THEN      'CIบ้านจารย์_BJ'
			WHEN Source_Definition_Code = '26'    THEN      'CIชบ_CP'
			WHEN Source_Definition_Code = '27'    THEN      'CIโดง_DO'
			WHEN Source_Definition_Code = '28'    THEN      'ตึกAKT'
			WHEN Source_Definition_Code = '29'    THEN      'ตึกCOHORT4'
			WHEN Source_Definition_Code = '30'    THEN      'ทารกแรกเกิด(Neonatal ward)'
			
			
	ELSE Source_Definition_Name -- ถ้าไม่ตรงกับเงื่อนไขใด ๆ ให้เก็บค่าเดิม
END,
Source_Group_Code = CASE

			WHEN Source_Definition_Code = '000'	  THEN	'OPD'
            WHEN Source_Definition_Code = '001'   THEN  'OPD'
            WHEN Source_Definition_Code = '002'   THEN  'OPD'
            WHEN Source_Definition_Code = '003'   THEN  'OPD'
            WHEN Source_Definition_Code = '004'   THEN  'OPD'
            WHEN Source_Definition_Code = '005'   THEN  'OPD'
            WHEN Source_Definition_Code = '006'   THEN  'OPD'
            WHEN Source_Definition_Code = '007'   THEN  'OPD'
            WHEN Source_Definition_Code = '008'   THEN  'OPD'
            WHEN Source_Definition_Code = '009'   THEN  'IPD'
            WHEN Source_Definition_Code = '010'   THEN  'OPD'
            WHEN Source_Definition_Code = '011'   THEN  'OPD'
            WHEN Source_Definition_Code = '012'   THEN  'OPD'
            WHEN Source_Definition_Code = '013'   THEN  'OPD'
            WHEN Source_Definition_Code = '014'   THEN  'OPD'
            WHEN Source_Definition_Code = '015'   THEN  'OPD'
            WHEN Source_Definition_Code = '016'   THEN  'OPD'
            WHEN Source_Definition_Code = '017'   THEN  'IPD'
            WHEN Source_Definition_Code = '018'   THEN  'OPD'
            WHEN Source_Definition_Code = '019'   THEN  'OPD'
            WHEN Source_Definition_Code = '020'   THEN  'OPD'
            WHEN Source_Definition_Code = '021'   THEN  'OPD'
            WHEN Source_Definition_Code = '022'   THEN  'OPD'
            WHEN Source_Definition_Code = '023'   THEN  'OPD'
            WHEN Source_Definition_Code = '024'   THEN  'OPD'
            WHEN Source_Definition_Code = '025'   THEN  'OPD'
            WHEN Source_Definition_Code = '026'   THEN  'OPD'
            WHEN Source_Definition_Code = '027'   THEN  'OPD'
            WHEN Source_Definition_Code = '028'   THEN  'OPD'
            WHEN Source_Definition_Code = '029'   THEN  'OPD'
            WHEN Source_Definition_Code = '030'   THEN  'OPD'
            WHEN Source_Definition_Code = '031'   THEN  'OPD'
            WHEN Source_Definition_Code = '032'   THEN  'OPD'
            WHEN Source_Definition_Code = '033'   THEN  'OPD'
            WHEN Source_Definition_Code = '034'   THEN  'OPD'
            WHEN Source_Definition_Code = '035'   THEN  'OPD'
            WHEN Source_Definition_Code = '036'   THEN  'OPD'
            WHEN Source_Definition_Code = '037'   THEN  'OPD'
            WHEN Source_Definition_Code = '038'   THEN  'IPD'
            WHEN Source_Definition_Code = '039'   THEN  'OPD'
            WHEN Source_Definition_Code = '040'   THEN  'OPD'
            WHEN Source_Definition_Code = '041'   THEN  'OPD'
            WHEN Source_Definition_Code = '042'   THEN  'OPD'
            WHEN Source_Definition_Code = '043'   THEN  'OPD'
            WHEN Source_Definition_Code = '044'   THEN  'OPD'
            WHEN Source_Definition_Code = '045'   THEN  'OPD'
            WHEN Source_Definition_Code = '046'   THEN  'OPD'
            WHEN Source_Definition_Code = '047'   THEN  'OPD'
            WHEN Source_Definition_Code = '048'   THEN  'OPD'
            WHEN Source_Definition_Code = '049'   THEN  'OPD'
            WHEN Source_Definition_Code = '050'   THEN  'OPD'
            WHEN Source_Definition_Code = '051'   THEN  'OPD'
            WHEN Source_Definition_Code = '052'   THEN  'OPD'
            WHEN Source_Definition_Code = '053'   THEN  'OPD'
            WHEN Source_Definition_Code = '054'   THEN  'IPD'
            WHEN Source_Definition_Code = '055'   THEN  'OPD'
            WHEN Source_Definition_Code = '056'   THEN  'OPD'
            WHEN Source_Definition_Code = '057'   THEN  'OPD'
            WHEN Source_Definition_Code = '058'   THEN  'OPD'
            WHEN Source_Definition_Code = '059'   THEN  'OPD'
            WHEN Source_Definition_Code = '060'   THEN  'OPD'
            WHEN Source_Definition_Code = '061'   THEN  'OPD'
            WHEN Source_Definition_Code = '062'   THEN  'OPD'
            WHEN Source_Definition_Code = '063'   THEN  'OPD'
            WHEN Source_Definition_Code = '064'   THEN  'OPD'
            WHEN Source_Definition_Code = '065'   THEN  'OPD'
            WHEN Source_Definition_Code = '066'   THEN  'OPD'
            WHEN Source_Definition_Code = '067'   THEN  'OPD'
            WHEN Source_Definition_Code = '068'   THEN  'OPD'
            WHEN Source_Definition_Code = '069'   THEN  'OPD'
            WHEN Source_Definition_Code = '070'   THEN  'OPD'
            WHEN Source_Definition_Code = '071'   THEN  'OPD'
            WHEN Source_Definition_Code = '072'   THEN  'OPD'
            WHEN Source_Definition_Code = '073'   THEN  'OPD'
            WHEN Source_Definition_Code = '074'   THEN  'OPD'
            WHEN Source_Definition_Code = '075'   THEN  'OPD'
            WHEN Source_Definition_Code = '076'   THEN  'OPD'
            WHEN Source_Definition_Code = '077'   THEN  'OPD'
            WHEN Source_Definition_Code = '078'   THEN  'OPD'
            WHEN Source_Definition_Code = '079'   THEN  'OPD'
            WHEN Source_Definition_Code = '080'   THEN  'IPD'
            WHEN Source_Definition_Code = '081'   THEN  'IPD'
            WHEN Source_Definition_Code = '082'   THEN  'IPD'
            WHEN Source_Definition_Code = '083'   THEN  'IPD'
            WHEN Source_Definition_Code = '084'   THEN  'IPD'
            WHEN Source_Definition_Code = '085'   THEN  'OPD'
            WHEN Source_Definition_Code = '086'   THEN  'OPD'
            WHEN Source_Definition_Code = '087'   THEN  'OPD'
            WHEN Source_Definition_Code = '088'   THEN  'OPD'
            WHEN Source_Definition_Code = '089'   THEN  'OPD'
            WHEN Source_Definition_Code = '090'   THEN  'OPD'
            WHEN Source_Definition_Code = '091'   THEN  'OPD'
            WHEN Source_Definition_Code = '092'   THEN  'OPD'
            WHEN Source_Definition_Code = '093'   THEN  'OPD'
            WHEN Source_Definition_Code = '094'   THEN  'OPD'
            WHEN Source_Definition_Code = '095'   THEN  'OPD'
            WHEN Source_Definition_Code = '096'   THEN  'IPD'
            WHEN Source_Definition_Code = '097'   THEN  'IPD'
            WHEN Source_Definition_Code = '098'   THEN  'OPD'
            WHEN Source_Definition_Code = '099'   THEN  'OPD'
            WHEN Source_Definition_Code = '100'   THEN  'OPD'
            WHEN Source_Definition_Code = '101'   THEN  'IPD'
            WHEN Source_Definition_Code = '102'   THEN  'IPD'
            WHEN Source_Definition_Code = '103'   THEN  'IPD'
            WHEN Source_Definition_Code = '104'   THEN  'OPD'
            WHEN Source_Definition_Code = '105'   THEN  'OPD'
            WHEN Source_Definition_Code = '106'   THEN  'IPD'
            WHEN Source_Definition_Code = '107'   THEN  'OPD'
            WHEN Source_Definition_Code = '108'   THEN  'OPD'
            WHEN Source_Definition_Code = '109'   THEN  'OPD'
            WHEN Source_Definition_Code = '110'   THEN  'OPD'
            WHEN Source_Definition_Code = '111'   THEN  'IPD'
            WHEN Source_Definition_Code = '112'   THEN  'OPD'
            WHEN Source_Definition_Code = '113'   THEN  'OPD'
            WHEN Source_Definition_Code = '114'   THEN  'OPD'
            WHEN Source_Definition_Code = '115'   THEN  'OPD'
            WHEN Source_Definition_Code = '116'   THEN  'OPD'
            WHEN Source_Definition_Code = '117'   THEN  'OPD'
            WHEN Source_Definition_Code = '118'   THEN  'OPD'
            WHEN Source_Definition_Code = '119'   THEN  'OPD'
            WHEN Source_Definition_Code = '120'   THEN  'IPD'
            WHEN Source_Definition_Code = '121'   THEN  'IPD'
            WHEN Source_Definition_Code = '122'   THEN  'OPD'
            WHEN Source_Definition_Code = '123'   THEN  'OPD'
            WHEN Source_Definition_Code = '124'   THEN  'OPD'
            WHEN Source_Definition_Code = '125'   THEN  'OPD'
            WHEN Source_Definition_Code = '126'   THEN  'OPD'
            WHEN Source_Definition_Code = '127'   THEN  'OPD'
            WHEN Source_Definition_Code = '128'   THEN  'OPD'
            WHEN Source_Definition_Code = '129'   THEN  'OPD'
            WHEN Source_Definition_Code = '130'   THEN  'OPD'
            WHEN Source_Definition_Code = '131'   THEN  'OPD'
            WHEN Source_Definition_Code = '132'   THEN  'OPD'
            WHEN Source_Definition_Code = '133'   THEN  'OPD'
            WHEN Source_Definition_Code = '134'   THEN  'OPD'
            WHEN Source_Definition_Code = '135'   THEN  'OPD'
            WHEN Source_Definition_Code = '136'   THEN  'OPD'
            WHEN Source_Definition_Code = '137'   THEN  'OPD'
            WHEN Source_Definition_Code = '138'   THEN  'OPD'
            WHEN Source_Definition_Code = '139'   THEN  'OPD'
            WHEN Source_Definition_Code = '999'   THEN  'OPD'
            WHEN Source_Definition_Code = '01'    THEN  'IPD'
            WHEN Source_Definition_Code = '02'    THEN  'IPD'
            WHEN Source_Definition_Code = '03'    THEN  'IPD'
            WHEN Source_Definition_Code = '05'    THEN  'IPD'
            WHEN Source_Definition_Code = '06'    THEN  'IPD'
            WHEN Source_Definition_Code = '07'    THEN  'IPD'
            WHEN Source_Definition_Code = '08'    THEN  'IPD'
            WHEN Source_Definition_Code = '09'    THEN  'IPD'
            WHEN Source_Definition_Code = '10'    THEN  'IPD'
            WHEN Source_Definition_Code = '11'    THEN  'IPD'
            WHEN Source_Definition_Code = '12'    THEN  'IPD'
            WHEN Source_Definition_Code = '13'    THEN  'IPD'
            WHEN Source_Definition_Code = '14'    THEN  'IPD'
            WHEN Source_Definition_Code = '15'    THEN  'IPD'
            WHEN Source_Definition_Code = '16'    THEN  'IPD'
            WHEN Source_Definition_Code = '17'    THEN  'IPD'
            WHEN Source_Definition_Code = '18'    THEN  'IPD'
            WHEN Source_Definition_Code = '19'    THEN  'IPD'
            WHEN Source_Definition_Code = '20'    THEN  'IPD'
            WHEN Source_Definition_Code = '21'    THEN  'IPD'
            WHEN Source_Definition_Code = '22'    THEN  'IPD'
            WHEN Source_Definition_Code = '23'    THEN  'IPD'
            WHEN Source_Definition_Code = '24'    THEN  'IPD'
            WHEN Source_Definition_Code = '25'    THEN  'IPD'
            WHEN Source_Definition_Code = '26'    THEN  'IPD'
            WHEN Source_Definition_Code = '27'    THEN  'IPD'
            WHEN Source_Definition_Code = '28'    THEN  'IPD'
            WHEN Source_Definition_Code = '29'    THEN  'IPD'
            WHEN Source_Definition_Code = '30'    THEN  'IPD'
	ELSE Source_Group_Code -- ถ้าไม่ตรงกับเงื่อนไขใด ๆ ให้เก็บค่าเดิม
END

WHERE Source_Definition_Code IN (
    '000','001','002','003','004','005','006','007','008','009','010','011','012','013','014','015','016','017','018','019','020','021','022','023','024','025','026','027','028','029','030','031','032','033','034','035','036','037','038','039','040','041','042','043','044','045','046','047','048','049','050','051','052','053','054','055','056','057','058','059','060','061','062','063','064','065','066','067','068','069','070','071','072','073','074','075','076','077','078','079','080','081','082','083','084','085','086','087','088','089','090','091','092','093','094','095','096','097','098','099','100','101','102','103','104','105','106','107','108','109','110','111','112','113','114','115','116','117','118','119','120','121','122','123','124','125','126','127','128','129','130','131','132','133','134','135','136','137','138','139','999','01','02','03','05','06','07','08','09','10','11','12','13','14','15','16','17','18','19','20','21','22','23','24','25','26','27','28','29','30' -- รายการ Source_Definition_Code ที่ต้องการอัปเดต
    -- เพิ่มรายการ Source_Definition_Code อื่น ๆ ต่อไป
	
);
Option Explicit
Sub TimeRightNow()
Dim T as Date		//Declare Variable 
T = now				//Give Variable T return Value of now function

MsgBox Format(T, "mm-dd-yyyy mm:hh")	//Display Formatted Date 

End Sub
Sub IncrCell()
Dim A as Integer 	// Variable declaration
A = 1					// Giving Variable A the Value 1

Range("A1").Value = Range("A1").Value + A  // This will Increase Cell A1 by "A"

End Sub
Sub FindExample()
    Dim searchRange As Range
    Dim foundCell As Range
    
    ' Set the range to search in (e.g., column A)
    Set searchRange = Range("A1:A10")
    
    ' Find the value "SearchValue" within the search range
    Set foundCell = searchRange.Find("SearchValue")
    
    ' Check if the value was found
    If Not foundCell Is Nothing Then
        ' Value was found
        MsgBox "Value found at cell " & foundCell.Address
    Else
        ' Value was not found
        MsgBox "Value not found"
    End If
End Sub
Sub find_method()
Dim cell As Range
Dim search_range As Range
Application.DisplayAlerts = False
On Error Resume Next
Set search_range = Application.InputBox("Select Your Range of Cells", "Search Range", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If search_range Is Nothing Then
Exit Sub
End If

For Each cell In search_range
Set cell = cell.Find("Mr.")
If Not cell Is Nothing Then
cell.Offset(0, 1).Value = "Male"
End If
Next cell

For Each cell In search_range
Set cell = cell.Find("Ms.")
If Not cell Is Nothing Then
cell.Offset(0, 1).Value = "Female"
End If
Next cell
MsgBox "Done"
End Sub
/****** Script for SelectTopNRows command from SSMS  ******/
SELECT 
      [LN]
      ,[HN]
      ,[FULLNAME]
     , [YEAR]

  
      ,[SEX]
      ,[BIRTHDATE]
    
      ,[WARD NAME]
      ,[PATIENT TYPE NAME]
      ,[DOCTOR NAME]
  
      ,[AN]
      ,[VN]
     ,[ORDER DATETIME]
       ,[IREQ_LAST_CHK_DT] as 'Checkin datetime'

      ,[RES ITEM NAME]
      ,[RES ITEM RESULT]

      ,[RES ITEM REPORT DATETIME]
      ,[RES ITEM REPORT STAFF NAME]
      ,[RES ITEM APPROVE DATETIME]
      ,[RES ITEM APPROVE STAFF NAME] 

--      ,[IREQ_LAST_APP_DT]
  FROM [LAB_DB].[dbo].[view_lab_statistic_Result_List]
  where [RES ITEM STATE] = 'A' and  HN in (SELECT  distinct HN
  FROM [LAB_DB].[dbo].[view_lab_statistic_Result_List]
  where [RES ITEM CODE] in ('IM1429','IM1430','IM1433','IM1448') and ([IREQ_LAST_CHK_DT] Between '@dt1' and '@dt2')) and [RES ITEM CODE] in ('IM1429','IM1430','IM1433','IM1448')
  
// 
// 24-8-65
if {RequestInfo.Report_By} = 'มัทนาวดี' then  'จพ.วิทยา'
else if {RequestInfo.Report_By} = 'สายทิพย์ ' then  'จพ.งาน'
else if {RequestInfo.Report_By} = 'ทนพ.ญ. ญาณิศา0' then  'Laboratory'
else if {RequestInfo.Report_By} = 'เข็มทอง' then  'Laboratory'
else if {RequestInfo.Report_By} = 'ทนพ.ญ.วัลดี  ' then  'Laboratory'
else if {RequestInfo.Report_By} = 'นายขวัญชัย สม0' then  'นักเทคนิคการแพทย์ชำนาญการ'
else if {RequestInfo.Report_By} = 'จริยา อิน' then  'นักเทคนิคการแพทย์'
else if {RequestInfo.Report_By} = 'administrator' then  'Administrator LIS'
Sub DeleteEntireRow()
Selection.EntireRow.Delete
End Sub
Sub DeleteBlankRows()
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Sub MoveToEnd()
    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xEndRow As Long
    Dim I As Long
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
lOne:
    Set xRg = Application.InputBox("Select range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    If xRg.Columns.Count > 1 Or xRg.Areas.Count > 1 Then
        MsgBox " Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lOne
    End If
    xEndRow = xRg.Rows.Count + xRg.Row
    Application.ScreenUpdating = False
    For I = xRg.Rows.Count To 1 Step -1
        If xRg.Cells(I) = "Done" Then
           xRg.Cells(I).EntireRow.Cut
           Rows(xEndRow).Insert Shift:=xlDown
        End If
    Next
    Application.ScreenUpdating = True
End Sub
Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub
'In this Example I am Copying the File From "C:Temp" Folder to "D:Job" Folder
Sub sbCopyingAFile()

'Declare Variables
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String

'This is Your File Name which you want to Copy
sFile = "Sample.xls"

'Change to match the source folder path
sSFolder = "C:Temp"

'Change to match the destination folder path
sDFolder = "D:Job"

'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'Checking If File Is Located in the Source Folder
If Not FSO.FileExists(sSFolder & sFile) Then
    MsgBox "Specified File Not Found", vbInformation, "Not Found"
    
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & sFile) Then
    FSO.CopyFile (sSFolder & sFile), sDFolder, True
    MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
    MsgBox "Specified File Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If

End Sub
Sub CreateValueFile()
  Dim wbCurr As Workbook, wbOut As Workbook
  Dim sName As String
  Dim sSheet As Worksheet, CurSheet As Worksheet
  Dim strFileExists As String
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Application.EnableEvents = False   'To avoid problems with Titus
  
  
  Set wbCurr = ThisWorkbook
  'Copy output template to output file
  sName = "C:\Users\ah19053\Aon\Bosch 2022 Global Actuary RFP - Central documents\040. Local fee collection\Bosch_2022_Fees_Template_v01.xlsx"
  Set wbOut = Workbooks.Open(Filename:=sName, UpdateLinks:=0)
  sName = "C:\Users\ah19053\Aon\Bosch 2022 Global Actuary RFP - Central documents\040. Local fee collection\Bosch_2022_Fees_v01.xlsx"
  strFileExists = Dir(sName)
  If strFileExists = "" Then
  Else
    Kill sName
  End If
  On Error GoTo 0
  wbOut.SaveAs Filename:=sName
  
  'loop through worksheets
  For Each sSheet In wbCurr.Worksheets
    If InStr(1, sSheet.Name, "Pricing") > 0 Then
      sSheet.Copy after:=wbOut.Sheets(wbOut.Sheets.Count)
      wbOut.Sheets(wbOut.Sheets.Count).Select
      Cells.Select
      Selection.Copy
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
      Application.CutCopyMode = False
      Range("a1").Select
      
      'Set CurSheet = wbOut.Sheets.Add
      
      'Debug.Print sSheet.Name
    End If
  Next sSheet
  
  wbOut.Save
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  MsgBox ("Program finished")
End Sub
Private Sub OpeFile_MutipleFile()

'VARIABLE'

Dim A As Variant
Dim AA As Variant

Dim B As Workbook
Dim C As Worksheet
Dim D As String

On Error Resume Next

'FUNCTION AS'
A = Application.GetOpenFilename(MultiSelect:=True, Password:=ABC)
D = ThisWorkbook.Worksheets("X").Range("A1").Value

'SET VARIABLE'
Set C = ThisWorkbook.Worksheets("Y")

For Each AA In A
	
	'OPEN FILE
	 Set B = Application.Workbooks.Open(AA)

    'CREATE CONDITIONS
    If C.Range("A2") = "" Then
  
		'TYPE PROCESS - 1 HERE'
		C.Range("B1").AutoFilter Field:=1, Criteria1:="TYPE1"
		C.Range("B1").CurrentRegion.Copy

		C.Range("B2").PasteSpecial xlPasteValues
		B.Close SaveChanges:=False
    
    'NEXT CONDTION CONDITIONS'
    Else

		'TYPE PROCESS - 2 HERE'
		C.Range("B1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 10).Select
		Range(Selection, Cells(1, 1)).Select
		Selection.Copy

		C.Range("B1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
		B.Close SaveChanges:=False

    End If
    
 On Error GoTo 0
    
Next

End Sub
Declare @MinValueWanted int = 500,
  @MaxValueWanted int = 3000;
Select abs(cast(newid() as binary(6)) % (1 + 9006 - 9001)) + 9001;

USE OLIS_DATA_DEMO;

/************/
--24_StaffNumberOfPersonInjured
UPDATE [dbo].[AIRSData]
SET [24_StaffNumberOfPersonInjured] = abs(cast(newid() as binary(6)) % (1 + 9006 - 9001)) + 9001
WHERE [24_StaffNumberOfPersonInjured] =9004 
AND [AIRSID] > 54812
Private Sub from_upper()
'SELECT CELL AFTER FILTER AND VISIBLE ONLY FROM UPPER WITHOUT TILE'

Dim ws As Worksheet
   
Set ws = Worksheets("Gen.Report")
ws.Activate
ws.Range("A1").Offset(1, 0).Select
Range(Selection, Selection.End(xlToRight)).Select
    
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
Range(Selection, Selection.End(xlToRight).End(xlDown)).Select


End Sub


'=============================================================================='


Private Sub from_below()
'SELECT CELL AFTER FILTER AND VISIBLE ONLY FROM BELOW WITH TILE'

Dim ws As Worksheet
   
Set ws = Worksheets("Gen.Report")
ws.Activate
ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Select
    
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
Range(Selection, Selection.End(xlToRight).End(xlUp)).Select


End Sub
' Put this code in your form's before_update

Private Sub Form_BeforeUpdate(Cancel As Integer)
Call AuditTrail(Me, [SUArchiveID])
End Sub



' Put code below in your Audit Module
Enum AuditAction
    Add
    Delete
    Edit
    Bulk
    DbgError
End Enum

Function getAuditEnumString(eValue As AuditAction) As String
    Select Case eValue
        Case Add
            getAuditEnumString = "ADD"
        Case Edit
            getAuditEnumString = "EDIT"
        Case Delete
            getAuditEnumString = "DELETE"
        Case DbgError
            getAuditEnumString = "ERROR"
    End Select
End Function





Public Sub AuditTrail(frm As Form, CourseID As String, recordID As String, Optional action As AuditAction)

  'Track changes to data.
  'recordid identifies the pk field's corresponding
  'control in frm, in order to id record.
  Dim ctl As Control
  Dim varBefore As Variant
  Dim varAfter As Variant
  Dim strControlName As String
  Dim strSQL As String
  Dim auditActionStr As String
  
  On Error GoTo ErrHandler
  
  
  
  If IsMissing(action) Then
    auditActionStr = getAuditEnumString(AuditAction.Edit)
    Else
        auditActionStr = getAuditEnumString(action)
  End If
  
  Dim sqlCollection As New Collection
  'On Error GoTo ErrHandler
  'Get changed values.
  For Each ctl In frm.Controls
    With ctl
    'Avoid labels and other controls with Value property.
    Select Case .ControlType
        Case acComboBox, acListBox, acTextBox
        If IsOldValueAvailable(ctl) Then
            If .value <> .oldValue Then
              varBefore = .oldValue
              varAfter = .value
              strControlName = .Name
              'Build INSERT INTO statement.
              strSQL = "INSERT INTO " _
                 & "Audit (EditDate, User, RecordID, SourceTable, " _
                 & " SourceField, BeforeValue, AfterValue, FormName, CourseID, Action) " _
                 & "VALUES (Now()," _
                 & cDQ & getLoggedInUserID & cDQ & ", " _
                 & cDQ & recordID & cDQ & ", " _
                 & cDQ & Replace(Left(frm.RecordSource, 255), Chr(34), "") & cDQ & ", " _
                 & cDQ & .Name & cDQ & ", " _
                 & cDQ & varBefore & cDQ & ", " _
                 & cDQ & varAfter & cDQ & ", " _
                  & cDQ & Left(frm.Name, 255) & cDQ & ", " _
                  & cDQ & CourseID & cDQ & ", " _
                  & cDQ & auditActionStr & cDQ & ")"
              
              'sqlCollection.Add strSQL
              CurrentDb.Execute strSQL
              'MsgBox "Audit " + strSQL
            End If
        End If
    End Select

    End With
  Next
  Set ctl = Nothing
  'Set AuditTrail = sqlCollection
  Exit Sub

ErrHandler:
  MsgBox "Audit Trail Error:" & Err.Description & vbNewLine _
   & Err.number, vbOKOnly, "Error"
End Sub

' SQL Code below to create Audit table
CREATE TABLE [dbo].[Audit](
	[EditedRecordID] [int] IDENTITY(1,1) NOT NULL,
	[EditDate] [datetime] NULL,
	[User] [nvarchar](255) NULL,
	[RecordID] [nvarchar](255) NULL,
	[SourceTable] [nvarchar](255) NULL,
	[SourceField] [nvarchar](255) NULL,
	[BeforeValue] [nvarchar](255) NULL,
	[AfterValue] [nvarchar](255) NULL,
	[FormName] [nvarchar](255) NULL,
	[CourseID] [nvarchar](255) NULL,
	[Action] [nvarchar](10) NULL,
 CONSTRAINT [Audit$PrimaryKey] PRIMARY KEY CLUSTERED 
(
	[EditedRecordID] ASC
)WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]
) ON [PRIMARY]



                Me!AdminStaffID = myLog!AdminStaffID
                If myLog!AdminStaffID = vbNullString Then
                    Me!AdminEmailAddress = ""
                    Me!AdminTelephone = ""
                Else
                    Me!AdminEmailAddress = DLookup("[WorkEmailAddress]", "tbl_Import_StaffListAll", "[StaffID] = [Forms]![ServiceProviderStructure - Sectors_Add_Edit]![AdminStaffID]")
                    Me!AdminTelephone = DLookup("[WorkMobileNumber]", "tbl_Import_StaffListAll", "[StaffID] = [Forms]![ServiceProviderStructure - Sectors_Add_Edit]![AdminStaffID]")
                End If
// https://www.thesmallman.com/looping-through-worksheets

Sub MovethroughWB1() 
'Excel VBA looping procedure, loop excludes first tab on the left'

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets 'Start the VBA Loop.
If ws.Index <> 1 Then 'Exclude the first sheet on the left from the procedure.n 'Perform the Action you wish.
ws.Range("B10:B20").Interior.Color=vbCyan
End If
Next ws
End Sub
// https://www.automateexcel.com/vba/sheets-worksheets
//  Guide Worksheet update by pp_92

'Tab Name'
Sheets("Input").Activate

'VBA Code Name'
Sheet1.Activate

'Index Position'
Sheets(1).Activate
	
'Select Sheet'
Sheets("Input").Select

'Set to Variable'
Dim ws as Worksheet
Set ws = ActiveSheet

'Name / Rename'
ActiveSheet.Name = "NewName"

'Rename as In Cell'
Worksheets(1).Name = Worksheets(1).Range("B5")

'Insert Name Worksheet in Cell'
ActiveSheet.Range("A1") = ActiveSheet.Name

'Rename as In Cell Loop'
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = rs.Range("B5")
Next rs

'Next Sheet'
ActiveSheet.Next.Activate

'Loop Through all Sheets'
Dim ws as Worksheet
For each ws in Worksheets
Msgbox ws.name
Next ws

'Loop Through Selected Sheets'
Dim ws As Worksheet
For Each ws In ActiveWindow.SelectedSheets
MsgBox ws.Name
Next ws

'Get ActiveSheet'
MsgBox ActiveSheet.Name

'Add Sheet'
Sheets.Add

'Add Sheet and Name'
Sheets.Add.Name = "NewSheet"

'Add Sheet With Name From Cell'
Sheets.Add.Name = range("a3").value

'Add Sheet After Another'
Sheets.Add After:=Sheets("Input")

'Add Sheet After and Name'
Sheets.Add(After:=Sheets("Input")).Name = "NewSheet"

'Add Sheet Before and Name'
Sheets.Add(Before:=Sheets("Input")).Name = "NewSheet"

'Add Sheet to End of Workbook'
Sheets.Add After:=Sheets(Sheets.Count)

'Add Sheet to Beginning of Workbook'
Sheets.Add(Before:=Sheets(1)).Name = "FirstSheet"

'Add Sheet to Variable'
Dim ws As Worksheet
Set ws = Sheets.Add

'Move Sheet to End of Workbook'
Sheets("Sheet1").Move After:=Sheets(Sheets.Count)

'To New Workbook'
Sheets("Sheet1").Copy

'Selected Sheets To New Workbook'
ActiveWindow.SelectedSheets.Copy

'Before Another Sheet'
Sheets("Sheet1").Copy Before:=Sheets("Sheet2")

'Before First Sheet'
Sheets("Sheet1").Copy Before:=Sheets(1)

'After Last Sheet'
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)

'Copy and Name'
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "LastSheet"

'Copy and Name From Cell Value'
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Range("A1").Value

'To Another Workbook'
Sheets("Sheet1").Copy Before:=Workbooks("Example.xlsm").Sheets(1)
	
'Hide Sheet'
Sheets("Sheet1").visible = False
or 
Sheets("Sheet1").visible = xlSheetHidden

'Unhide Sheet'
Sheets("Sheet1").Visible = True
or
Sheets("Sheet1").Visible = xlSheetVisible

'Very Hide Sheet'
Sheets("Sheet1").Visible = xlSheetVeryHidden

'Delete Sheet'
Sheets("Sheet1").Delete

'Delete Sheet (Error Handling)'
On Error Resume Next
Sheets("Sheet1").Delete
On Error GoTo 0

'Delete Sheet (No Prompt)'
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True

'Clear Sheet'
Sheets("Sheet1").Cells.Clear

'Clear Sheet Contents Only'
Sheets("Sheet1").Cells.ClearContents

'Clear Sheet UsedRange'
Sheets("Sheet1").UsedRange.Clear

'Unprotect (No Password)'
Sheets("Sheet1").Unprotect

'Unprotect (Password)'
Sheets("Sheet1").Unprotect "Password"

'Protect (No Password)'
Sheets("Sheet1").Protect

'Protect (Password)'
Sheets("Sheet1").Protect "Password"

'Protect but Allow VBA Access'
Sheets("Sheet1").Protect UserInterfaceOnly:=True

'Unprotect All Sheets'
Dim ws As Worksheet
For Each ws In Worksheets
ws.Unprotect "password"
Next ws
Private Sub MoveSheetRight()
'MOVE WORKSHEET TO RIGHT'

Dim s As Worksheet
Set s = ActiveSheet

If s.Next Is Nothing Then Exit Sub
s.Move after:=s.Next

End Sub



Private Sub MoveSheetLeft()
'MOVE WORKSHEET TO LEFT'

Dim s As Worksheet
Set s = ActiveSheet

If s.Previous Is Nothing Then Exit Sub
s.Move before:=s.Previous

End Sub



Private Sub ActiveSheetbyCount()
'GO TO ACTIVE WORKSHEET TO RIGHT STEP TO STEP'

If ActiveSheet.Index < ThisWorkbook.Sheets.Count Then
Sheets(ActiveSheet.Index + 1).Activate
    Else
    Sheets(1).Activate
End If

End Sub



Private Sub GoTolastSheet()
'GO TO ACTIVE WORKSHEET TO LAST SHEET - RIGHT'

On Error Resume Next
Sheets(Sheets.Count).Select

End Sub



Private Sub GoToFirstSheet()
'GO TO ACTIVE WORKSHEET TO LAST SHEET - LEFT'

On Error Resume Next
Sheets(1).Select

End Sub
Sub create_sheet_from_list()

Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("Generate").Range("C6")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False

    For Each MyCell In MyRange
        If MyCell.Value = "" Then 'Check for null/empty value cell'
            Exit Sub 'If reach to null cell then exit sub'
        Else
            Sheets("X").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet'
            Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet'
        End If
    Next MyCell
    
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.EnableEvents = True

End Sub
Sub newB()
    Dim rgnFilter As Range, rgnArea As Range, rgnRow As Range
    Dim i As Long, lastRow As Long
    Dim toDelete As Boolean

    With Sheet1
        'If data is unfiltered then exit sub'
        If .AutoFilterMode = False Then
            MsgBox "Please filter the data first.", vbInformation
            Exit Sub
        End If
        
        'Get lastRow data'
        lastRow = .Range("C" & Rows.Count).End(xlUp).Row
        
        'Set column C filtered data as rgn'
        Set rgnFilter = .Range("C7:C" & lastRow).SpecialCells(xlCellTypeVisible)
        
        toDelete = False
        
        'loop each filtered area'
        For Each rgnArea In rgnFilter.Areas
        
            'If filtered area have rows>1 then proceed'
            If rgnArea.Rows.Count > 1 Then
            
                'Loop each cell in each filtered area'
                For Each rgnRow In rgnArea
                
                    'If toDelete = false then skip else delete in cell B row'
                    If toDelete = False Then
                        toDelete = True
                    Else
                        .Range("B" & rgnRow.Row).Value = Empty
                        toDelete = False
                    End If
                Next rgnRow
            End If
        Next rgnArea
        
        'Unfilter sheet'
        .AutoFilterMode = False
    End With
    
End Sub
Private Sub Excel3rd_as_Generator()

Dim A As String
Dim B1 As Workbook, B2 As Workbook
Dim C As String

'PATH REPORT TO PASTE'
'A = "C:\Users\phareh\Desktop\x.xlsm"'
A = ThisWorkbook.Worksheets("SRM_BAL_R2018_AR").Range("H4").Value
'PATH DATA REPORT TO COPY'
'A = "C:\Users\phareh\Download\y.xlsm"'
C = ThisWorkbook.Worksheets("SRM_BAL_R2018_AR").Range("E4").Value

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False

On Error Resume Next

Set B1 = Application.Workbooks.Open(A)

'IF DATA EMPTY THEN PASTE'
If B1.Sheets(1).Range("A2") = "" Then
Set B2 = Application.Workbooks.Open(C)
B.Activate
Rows("6:6").Select

'CREATE FILTER'
Selection.AutoFilter
ActiveSheet.Range("A6:O6").AutoFilter Field:=5, Criteria1:="SRM"
B.Sheets(1).Range("A6:O6").Select
Range(Selection, Selection.End(xlDown)).Copy
B1.Sheets("R2018 (AR)").Range("A1").PasteSpecial
B2.Close False
B1.Close SaveChanges:=True
    
	'IF DATA EXIST THEN PASTE'
    Else
    Set B2 = Application.Workbooks.Open(C)
    B.Activate
    Rows("6:6").Select
	
	'CREATE FILTER'
    Selection.AutoFilter
    ActiveSheet.Range("A6:O6").AutoFilter Field:=5, Criteria1:="SRM"
    B.Sheets(1).Range("A6:O6").Select
    Range(Selection, Selection.End(xlDown)).Copy
    B1.Sheets("R2018 (AR)").Activate
    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
    B2.Close False
    B1.Close SaveChanges:=True
                
End If

On Error GoTo 0

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.EnableEvents = True

End Sub
// .vbs file
Dim args, objExcel

set args = wscript.Arguments
set objExcel = createobject("Excel.Application")

objExcel.workbooks.open args(0) 
objExcel.visible = True

objExcel.Run "Module1.Macro1"
objExcel.Activeworkbook.Save 
objExcel.Activeworkbook.Close(0)
objExcel.Quit



// .bat file
cscript "C:\Users\phareh_92(2)\Documents\X.vbs" "C:\Users\phareh_92(2)\Documents\Y.xlsm"
Private Sub Create_Folder()
'CREATE FOLDER'

Dim ToPath As String

ToPath = ThisWorkbook.Worksheets("1").Range("A1").Value
MkDir ToPath

End Sub


Sub Copy_One_File()
    FileCopy "C:\Users\Ron\SourceFolder\Test.xls", "C:\Users\Ron\DestFolder\Test.xls"
End Sub

Sub Move_Rename_One_File()
'You can change the path and file name'
    Name "C:\Users\Ron\SourceFolder\Test.xls" As "C:\Users\Ron\DestFolder\TestNew.xls"
End Sub

Sub Delete_One_File()
'You can change the path and file name'
    Kill "C:\Users\Ron\SourceFolder\Test.xls"
End Sub
 
'Copy or move more files or complete folders'
'Note: Read the commented code lines in the code'

Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath'
'Note: If ToPath already exist it will overwrite existing files in this folder'
'if ToPath not exist it will be made for you'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'

    'If you want to create a backup of your folder every time you run this macro'
    'you can create a unique folder with a Date/Time stamp.'
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss").'

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath

End Sub

Sub Move_Rename_Folder()
'This example move the folder from FromPath to ToPath'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'
    'Note: It is not possible to use a folder that exist in ToPath'

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = True Then
        MsgBox ToPath & " exist, not possible to move to a existing folder"
        Exit Sub
    End If

    FSO.MoveFolder Source:=FromPath, Destination:=ToPath
    MsgBox "The folder is moved from " & FromPath & " to " & ToPath

End Sub


Sub Copy_Files_Dates()
'This example copy all files between certain dates from FromPath to ToPath'
'You can also use this to copy the files from the last ? days'
'If Fdate >= Date - 30 Then'
'Note: If the files in ToPath already exist it will overwrite'
'existing files in this folder'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim Fdate As Date
    Dim FileInFromFolder As Object

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    If Right(ToPath, 1) <> "\" Then
        ToPath = ToPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
        If Fdate >= DateSerial(2006, 10, 1) And Fdate <= DateSerial(2006, 11, 1) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub


Sub Copy_Certain_Files_In_Folder()
'This example copy all Excel files from FromPath to ToPath'
'Note: If the files in ToPath already exist it will overwrite'
'existing files in this folder'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim FileExt As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'

    FileExt = "*.xl*"  '<< Change
    'You can use *.* for all files or *.doc for Word files'

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub

Sub Move_Certain_Files_To_New_Folder()
'This example move all Excel files from FromPath to ToPath'
'Note: It will create the folder ToPath for you with a date-time stamp'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim FileExt As String
    Dim FNames As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss") _
           & " Excel Files" & "\"    '<< Change only the destination folder'

    FileExt = "*.xl*"   '<< Change'
    'You can use *.* for all files or *.doc for word files'

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        MsgBox "No files in " & FromPath
        Exit Sub
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    FSO.CreateFolder (ToPath)

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub

'VBA Deleting All Files and Subfolders'
Sub VBAF1_Delete_All_Files_and_Subfolders()
    
    'Variable declaration'
    Dim sFolderPath As String
    Dim FSO As Object
    
     'Define Folder Path'
    sFolderPath = "C:\VBAF1\Test\"
    
    'Check if slash is added'
    If Right(sFolderPath, 1) = "\" Then
        'If added remove it from the specified path'
        sFolderPath = Left(sFolderPath, Len(sFolderPath) - 1)
    End If
            
    'Create FSO Object'
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'Check Specified Folder exists or not'
    If FSO.FolderExists(sFolderPath) Then
    
          'Delete All Files'
          FSO.DeleteFile sFolderPath & "\*.*", True
                        
          'Delete All Subfolders'
		  'Change the code'
          FSO.DeleteFolder sFolderPath & "\*.*", True

			
		 'Remark Sample:'
		 'Sample Delete File in Folder Download "C:\Users\Downloads\"'
		 'FSO.DeleteFolder sFolderPath & "\*.*", True'

		 'Sample Delete Folder in Folder Download "C:\Users\Downloads\FOLDER1\"'
		 'FSO.DeleteFolder sFolderPath , True'
          
     End If
    
End Sub
Public Function AllProcs(ByVal strDatabasePath As String, ByVal strModuleName As String)
    Dim appAccess As Access.Application
    Dim db As Database
    Dim mdl As Module
    Dim lngCount As Long
    Dim lngCountDecl As Long
    Dim lngI As Long
    Dim strProcName As String
    Dim astrProcNames() As String
    Dim intI As Integer
    Dim strMsg As String
    Dim lngR As Long

    Set appAccess = New Access.Application

    appAccess.OpenCurrentDatabase strDatabasePath
    ' Open specified Module object.
    appAccess.DoCmd.OpenModule strModuleName
    ' Return reference to Module object.
    Set mdl = appAccess.Modules(strModuleName)
    ' Count lines in module.
    lngCount = mdl.CountOfLines
    ' Count lines in Declaration section in module.
    lngCountDecl = mdl.CountOfDeclarationLines
    ' Determine name of first procedure.
    strProcName = mdl.ProcOfLine(lngCountDecl + 1, lngR)
    ' Initialize counter variable.
    intI = 0        ' Redimension array.
    ReDim Preserve astrProcNames(intI)
    ' Store name of first procedure in array.
    astrProcNames(intI) = strProcName
    ' Determine procedure name for each line after declarations.
    For lngI = lngCountDecl + 1 To lngCount
        ' Compare procedure name with ProcOfLine property value.
        If strProcName <> mdl.ProcOfLine(lngI, lngR) Then
            ' Increment counter.
            intI = intI + 1
            strProcName = mdl.ProcOfLine(lngI, lngR)
            ReDim Preserve astrProcNames(intI)
            ' Assign unique procedure names to array.
            astrProcNames(intI) = strProcName
        End If
    Next lngI
    strMsg = "Procedures in module '" & strModuleName & "': " & vbCrLf & vbCrLf
    For intI = 0 To UBound(astrProcNames)
        strMsg = strMsg & astrProcNames(intI) & vbCrLf
    Next intI
    ' Message box listing all procedures in module.
    Debug.Print strMsg
    appAccess.CloseCurrentDatabase
    appAccess.Quit
    Set appAccess = Nothing
End Function
Public Sub SolveFive(Optional ShowAlert As Boolean = True)

'Purpose    : Runs Solver Loops through the '5YrChoice_MVoptions' Tab
'Author     : Jimmy Briggs <jimmy.briggs@pwc.com>
'Description: Automate Workflow for RLUS Client
'Date       : 2022-02-04

 Application.ScreenUpdating = False
 Application.DisplayStatusBar = True
 Application.Cursor = xlWait
 On Error GoTo HandleError

 Dim changeCells As Range
 Dim Result As Integer
 Dim i As Integer
 Dim StartTime As Double
 Dim SecondsElapsed As Double

 StartTime = Timer

 Application.StatusBar = "Starting Macro for 5YrChoice_MVoptions, please be patient..."

 Sheets("5YrChoice_MVoptions").Select

 For i = 3 To 62 Step 1
    Application.StatusBar = "Running Solver on iteration " & i & " out of 62."
    Set changeCells = ActiveSheet.Range(Range(Cells(i, 28).Address, Cells(i, 29).Address).Address)
    SolverReset
    SolverOptions precision:=0.000000001
    SolverOK SetCell:=Cells(i, 35).Address, MaxMinVal:=2, byChange:=changeCells.Address
    SolverAdd CellRef:=Cells(i, 36).Address, Relation:=2, FormulaText:=0
    SolverAdd CellRef:=changeCells.Address, Relation:=3, FormulaText:=0.0000000001
    Result = SolverSolve(True)

    If Result <= 3 Then
        SolverFinish KeepFinal:=1
    Else
        Beep
        MsgBox "Solver was unable to find a solution.", vbExclamation, "SOLUTION NOT FOUND"
        SolverFinish KeepFinal:=2
        GoTo Skip
    End If

Skip:
    SolverFinish KeepFinal:=2
    Next i

 Sheets("Comparison").Select
 SecondsElapsed = Round(Timer - StartTime, 2)
 Range("Latest_Execution_Time_5").Value = SecondsElapsed

 If ShowAlert = True Then
    MsgBox "Successfully ran code in " & SecondsElapsed & " seconds", vbInformation
 End If

 Application.StatusBar = "Done running Solver for sheet 5YrChoice_MVoptions."
 Application.OnTime Now + TimeValue("00:00:07"), "clearStatusBar"
 Application.ScreenUpdating = True

HandleExit:
    Application.Cursor = xlDefault
    Exit Sub
HandleError:
    MsgBox Err.Description
    Resume HandleExit

End Sub
Sub ClearData()
 
Worksheets("Clients").Rows("2:" & Rows.Count).ClearContents
Worksheets("Cases").Rows("2:" & Rows.Count).ClearContents
Worksheets("Sessions").Rows("2:" & Rows.Count).ClearContents
 
End Sub
Public Function RefreshLinks(ByVal sDatabase As String) As Boolean
On Error GoTo ErrorOut
 
    'Refresh table links to a backend database
 
    Dim dbs As Database
    Dim tdf As TableDef
    Dim sCurrentTDF As String
 
    ' Loop through all tables in the database.
    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        ' If the table has a connect string, it's a linked table.
        If Len(tdf.Connect) > 0 Then
            tdf.Connect = "ODBC;Driver={SQL SERVER};" & "Server=DBSERVER\DB1;" & "Database=" & sDatabase & ";" & "Trusted_Connection=no;" & "Uid=sa;" & "Pwd=secret"
            Err = 0
            On Error Resume Next
            sCurrentTDF = tdf.Name
            tdf.RefreshLink ' Relink the table.
            If Err <> 0 Then
                RefreshLinks = False
                Exit Function
            End If
        End If
    Next tdf
 
    RefreshLinks = True
ExitOut:
    Exit Function
ErrorOut:
     msgBox ("There was an error refreshing the link(s) for '" & sCurrentTDF & "':  " & vbCrLf & vbCrLf & Err.Description)
     Resume ExitOut
End Function
=TEXT(D2; "JJJJ-MM-TT hh:mm:ss")
Private Sub Select_Sector()

Dim rs As DAO.Recordset

Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")

Dim qdef As QueryDef
Set qdef = getCurrentDb.QueryDefs("qry_Select_Sector")
qdef.Connect = CurrentDb.TableDefs("BOCClientIndex").Connect


RegEx.Pattern = "IIf\(\[ServiceStatus\]=3,30,20\)\)=([0-9]+)"
qdef.SQL = RegEx.Replace(qdef.SQL, "IIf([ServiceStatus]=3,30,20))=" & [Forms]![MainMenu_Services]![SelectedStatusIndicator])

RegEx.Pattern = "\(View_qryServiceProviderOrganisationalStructure\.SectorCode\)=([0-9]+)"
qdef.SQL = RegEx.Replace(qdef.SQL, "(View_qryServiceProviderOrganisationalStructure.SectorCode)=" & [Forms]![MainMenu_Services]![SectorCode])


'For Testing purposes only - Do not use in production code
Set rs = qdef.OpenRecordset

Dim i As Long
For i = 0 To rs.Fields.Count - 1
        Debug.Print rs.Fields(i).Name,
    Next
    rs.MoveFirst
    Do Until rs.EOF
        Debug.Print
        For i = 0 To rs.Fields.Count - 1
            Debug.Print rs.Fields(i).value,
        Next
        rs.MoveNext
    Loop
End Sub
Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")

RegEx.Pattern = "\[UserID\]=([0-9]+)"
Set qdef = getCurrentDb.QueryDefs("Query Course List PASSTHRU")
qdef.SQL = RegEx.Replace(qdef.SQL, "[UserID]=" & getLoggedInUserID)


Query:
[Cost Centre Descriptions].[Sector Code] IN (

SELECT [SectorCode]
FROM [tbl_TRNG_PermissionsBySector] WITH (NOLOCK)
WHERE [UserID]=9999 AND ViewSector=1

)
Option Explicit

Sub q4()

 Dim q4a(1 To 25, 1 To 25) As Double
 Dim col As Integer, row As Integer
 
 For col = 1 To 25
 For row = 1 To 25
    q4a(row, col) = WorksheetFunction.RandBetween(100, 1000)
 Next row
 Next col
  
 range("B2").Resize(25, 25) = q4a

End Sub

Function exammax(bigrange As range) As String

Dim cell As range, maxval As Double

Set bigrange = range("B2:Z26")
maxval = range("B2")

For Each cell In bigrange
 If cell >= maxval Then maxval = cell
Next cell

exammax = maxval

End Function

Function exammin(bigrange As range) As String

Dim cell As range, minval As Double

Set bigrange = range("B2:Z26")
minval = range("B2")

For Each cell In bigrange
 If cell <= minval Then minval = cell
Next cell

exammin = minval

End Function

Sub sortino()

Dim bigrange As range, cell As range, counter As Integer, cellmean As Double

Set bigrange = range("B2:Z26")
cellmean = WorksheetFunction.Average(bigrange)
counter = 2

For Each cell In bigrange
    If cell <= cellmean Then
    Cells(28, counter) = cellmean - cell
    counter = counter + 1
    End If
    Next cell

range("A31") = "sortino ratio"
range("B31") = WorksheetFunction.Average(range(Cells(28, 2), Cells(28, counter)))

End Sub

Option Explicit

Function bscholes(rf As Double, so As Double, X As Double, sd As Double) As Double

Dim d1 As Double, d2 As Double, nd1 As Double, nd2 As Double, c As Double

d1 = (Log(so / X) + (rf + 0.5 * sd * sd) * 0.25) / (sd * Sqr(0.25))
d2 = d1 - (sd * Sqr(0.25))
nd1 = WorksheetFunction.Norm_S_Dist(d1, True)
nd2 = WorksheetFunction.Norm_S_Dist(d2, True)
c = so * nd1 - X * Exp(-rf * 0.25) * nd2

bscholes = c

End Function
Option Explicit
Sub mcSim()

    range("C16").Clear
    range("E3", "AL100").Clear

    Dim mcSim() As Double, mu As Double, iters As Integer, time As Integer
    Dim sd As Double, row As Integer, col As Integer

    
    time = InputBox("On which day would you like to exercise your option? (select a number between 1 and 63)")
    
    ReDim mcSim(1 To time, 1 To 30)
    iters = range("C17")
    range("B16").Value = "Selected exercise day"
    range("C16").Value = time

' Here you want to set the mean and stddev
' to whichever cell contains your inputs

    mu = range("C11")
    sd = range("C12")
    
    Randomize
    
   'i is rows, j is cols
   
    For col = 1 To iters
        For row = 1 To time
            mcSim(row, col) = mu + sd * WorksheetFunction.Norm_S_Inv(Rnd)
        Next row
    Next col

    range("F4").Resize(time, iters) = mcSim

    'label 2x2 array
    
    For col = 1 To 30
        For row = 1 To time
            Cells(row + 3, 5) = row
            Cells(3, col + 5) = col
        Next row
    Next col
    
    range("E3").Value = "Day"
    range(Cells(3, 5), Cells(time + 3, 5)).Interior.ColorIndex = 24
    range(Cells(3, 5), Cells(time + 3, 5)).HorizontalAlignment = xlCenter
    
End Sub
Sub FV1rand()

Dim col As Integer, row As Integer
Dim myrange As range
Dim time As Integer

time = range("C16")

For col = 6 To 35
    For row = 4 To time + 3
        Cells(row, 37) = 1 + Cells(row, col)
    Next row
    
    Set myrange = range(Cells(4, 37), Cells(time + 3, 37))
    Cells(time + 5, col) = WorksheetFunction.Product(myrange)
Next col
    
Cells(time + 5, 5) = "Future value of R1"
Cells(time + 5, 5).Interior.ColorIndex = 24

End Sub

Sub valuecalcs()

Dim col As Integer, row As Integer
Dim myrange As range
Dim time As Integer

time = range("C16")

Cells(time + 6, 5) = "ST"
Cells(time + 7, 5) = "X"
Cells(time + 8, 5) = "Max(ST-X,0)"
Cells(time + 9, 5) = "DCF"
Cells(time + 11, 5) = "Average DCF"


For col = 6 To 35
    Cells(time + 6, col) = WorksheetFunction.Product(Cells(time + 5, col), Cells(3, 3))
    Cells(time + 7, col) = range("C7")
    If Cells(time + 6, col) - Cells(time + 7, col) <= 0 Then
        Cells(time + 8, col) = 0
        Else
            Cells(time + 8, col) = Cells(time + 6, col) - Cells(time + 7, col)
        End If
    Cells(time + 9, col) = WorksheetFunction.Product(Cells(time + 8, col), Cells(14, 3))
    Next col
    
Set myrange = range(Cells(time + 9, 6), Cells(time + 9, 35))
Cells(time + 11, 6) = WorksheetFunction.Average(myrange)

Cells(time + 6, 5).Interior.ColorIndex = 24
Cells(time + 7, 5).Interior.ColorIndex = 24
Cells(time + 8, 5).Interior.ColorIndex = 24
Cells(time + 9, 5).Interior.ColorIndex = 24
Cells(time + 11, 5).Interior.ColorIndex = 17
Cells(time + 6, 5).HorizontalAlignment = xlCenter
Cells(time + 7, 5).HorizontalAlignment = xlCenter
Cells(time + 8, 5).HorizontalAlignment = xlCenter
Cells(time + 9, 5).HorizontalAlignment = xlCenter
Cells(time + 11, 5).HorizontalAlignment = xlCenter
    
End Sub
Option Explicit

Sub mcSim()

    Dim mcSim(1 To 63, 1 To 30) As Double, mu As Double
    Dim sd As Double, i As Integer, j As Integer

    mu = Range("C11")
    sd = Range("C12")
    
    Randomize
    
    'fill 2x2 array
    
    For j = 1 To 30
        For i = 1 To 63
            mcSim(i, j) = mu + sd * WorksheetFunction.Norm_S_Inv(Rnd)
        Next i
    Next j

    Range("F4").Resize(63, 30) = mcSim

    'label 2x2 array
    
    For j = 1 To 30
        For i = 1 To 63
            Cells(i + 3, 5) = i
            Cells(3, j + 5) = j
        Next i
    Next j

    
End Sub

Sub valuecalcs()

Dim col As Integer, row As Integer
Dim myrange As Range

For col = 6 To 35
    For row = 4 To 66
        Cells(row, 37) = 1 + Cells(row, col)
    Next row
    
    Set myrange = Range(Cells(4, 37), Cells(66, 37))
    Cells(68, col) = WorksheetFunction.Product(myrange)
Next col
    
Range("E68").Value = "Future value of R1"

End Sub

Sub valuecalcs2()

Dim col As Integer, row As Integer
Dim myrange As Range

Range("E69").Value = "ST"
Range("E70").Value = "X"
Range("E71").Value = "Max(ST-X,0)"
Range("E72").Value = "DCF"
Range("E74").Value = "Average DCF"


For col = 6 To 35
    Cells(69, col) = WorksheetFunction.Product(Cells(68, col), Cells(3, 3))
    Cells(70, col) = Range("C7")
    If Cells(69, col) - Cells(70, col) <= 0 Then
        Cells(71, col) = 0
        Else
            Cells(71, col) = Cells(69, col) - Cells(70, col)
        End If
    Cells(72, col) = WorksheetFunction.Product(Cells(71, col), Cells(14, 3))
    Next col
    
Set myrange = Range(Cells(72, 6), Cells(72, 35))
Cells(74, 6) = WorksheetFunction.Average(myrange)
    
End Sub
Option Explicit

Sub mcSim()

' This sub will populate a 30x10 array with
' values according to the formula in the revision
' lecture

    Dim mcSim(1 To 30, 1 To 10) As Double, mu As Double
    Dim sd As Double, i As Integer, j As Integer


' Here you want to set the mean and stddev
' to whichever cell contains your inputs

    mu = 0.000238095
    sd = 0.008819171
    
    Randomize
    
    For j = 1 To 10
        For i = 1 To 30
            mcSim(i, j) = mu + sd * WorksheetFunction.Norm_S_Inv(Rnd)
        Next i
    Next j

    Range("I6").Resize(30, 10) = mcSim


End Sub
Dim i As Integer

For i = 3 To 26
If Cells(i, 2) >= 0.5 Then
Cells(i, 3).Value = "Upper"
Cells(i, 3).Font.Bold = True
End If
Next i

End Sub

Sub cumulate()

Dim i As Integer

Range("D3").Value = Range("B3").Value

For i = 4 To 26
Cells(i, 4) = Cells(i - 1, 4) + Cells(i, 2)
Next i

End Sub
Sub populaterange()

Dim myrange As range

Set myrange = range("C2:J12")
myrange.Value = "=rand()"

range("C14").Value = "Average"
range("D14").Formula = WorksheetFunction.Average(myrange)

range("C15").Value = "Sum"
range("D15").Formula = WorksheetFunction.Sum(myrange)

End Sub
Sub rangething()

Dim myrange As range

Set myrange = range("B5:H10")
myrange.Value = "=rand()"

End Sub
import tabula
df = tabula.read_pdf(r'C:\Users\igrod\Downloads\tabela nieruchomosci.pdf', pages='all')
tabula.convert_into(r'C:\Users\igrod\Downloads\tabela nieruchomosci.pdf', r'C:\Users\igrod\Downloads\tabela nieruchomosci.csv', output_format="csv", pages='all')
Sub display_all_chart_shapes()

    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            Debug.Print counter & "##" & sld.Name & " " & shp.Name
        Next shp
        counter = counter + 1
    Next sld

End Sub

Function pieknosc()
    
    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            'Debug.Print counter & "##" & sld.Name & " " & shp.Name
            '
            '
            ' KOMENTARZE
            '
            '
            If shp.Name = "TextBox 11" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 460
                shp.Width = 720
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 9
            End If
            '
            '
            ' PODTYTUŁY
            '
            '
            If shp.Name = "Podtytuł 2" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 10
                shp.Width = 900
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 24
            End If
            
            
            
        Next shp
        counter = counter + 1
    Next sld
End Function
Function Ping(strip)
Dim objshell, boolcode
Set objshell = CreateObject("Wscript.Shell")
boolcode = objshell.Run("ping -n 1 -w 1000 " & strip, 0, True)
If boolcode = 0 Then
    Ping = True
Else
    Ping = False
End If
End Function
Sub PingSystem()
Dim strip As String
Dim strPhoneNumber As String
Dim strMessage As String
Dim strPostData As String
Dim IE As Object

strPhoneNumber = Sheets("DATA").Cells(2, 1).Value

For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
    strip = ActiveSheet.Cells(introw, 2).Value
    If Ping(strip) = True Then
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Online"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 200, 0)
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Online"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"

        Set IE = Nothing
        
    Else
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(200, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Offline"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 6
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Offline"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"
        Set IE = Nothing
    End If
Next
End Sub
Sub PAUSE(Period As Single)
Dim TimeNow As Single
TimeNow = Timer
Do
    DoEvents
Loop While TimeNow + Period > Timer
End Sub
Sub ClearData()

Worksheets("Clients").Rows("2:" & Rows.Count).ClearContents
Worksheets("Cases").Rows("2:" & Rows.Count).ClearContents
Worksheets("Sessions").Rows("2:" & Rows.Count).ClearContents

End Sub
star

Sun Aug 04 2024 07:19:18 GMT+0000 (Coordinated Universal Time) https://learn.microsoft.com/ru-ru/office/vba/excel/concepts/workbooks-and-worksheets/create-a-scheduling-calendar-workbook

#vba
star

Sat Aug 03 2024 14:31:33 GMT+0000 (Coordinated Universal Time) https://tutorialhorizon.com/excel/vba-excel-sudoku-solver/

#vba
star

Thu May 30 2024 16:21:27 GMT+0000 (Coordinated Universal Time)

#vba
star

Fri May 17 2024 22:57:39 GMT+0000 (Coordinated Universal Time)

#vba
star

Wed Dec 06 2023 13:06:32 GMT+0000 (Coordinated Universal Time)

#vba
star

Thu Oct 19 2023 23:58:36 GMT+0000 (Coordinated Universal Time)

#sql #vba #ilink #lis #gqry
star

Tue Oct 17 2023 09:08:37 GMT+0000 (Coordinated Universal Time) https://www.mycompiler.io/view/GdCa0p9NWMS

#sql #vba #ilink #lis #gqry
star

Tue Oct 10 2023 08:09:53 GMT+0000 (Coordinated Universal Time)

#sql #vba #ilink #lis #gqry
star

Thu Oct 05 2023 01:50:24 GMT+0000 (Coordinated Universal Time)

#sql #vba #ilink #lis #gqry
star

Fri Sep 22 2023 08:34:18 GMT+0000 (Coordinated Universal Time)

#sql #vba
star

Fri Aug 25 2023 03:39:08 GMT+0000 (Coordinated Universal Time) https://www.mycompiler.io/view/3MNfG0ssCOF

#sql #vba
star

Fri Aug 18 2023 08:48:29 GMT+0000 (Coordinated Universal Time)

#vba
star

Wed Aug 16 2023 09:40:38 GMT+0000 (Coordinated Universal Time)

#sql #vba
star

Thu Aug 03 2023 21:42:37 GMT+0000 (Coordinated Universal Time)

#vba
star

Thu Aug 03 2023 21:25:03 GMT+0000 (Coordinated Universal Time)

#vba
star

Tue Jun 20 2023 06:33:46 GMT+0000 (Coordinated Universal Time)

#vba
star

Mon Jun 19 2023 10:49:29 GMT+0000 (Coordinated Universal Time) https://www.exceldemy.com/excel-vba-find-string-in-cell/

#vba
star

Thu Jun 15 2023 04:26:24 GMT+0000 (Coordinated Universal Time)

#sql #vba
star

Sun Jun 04 2023 06:37:09 GMT+0000 (Coordinated Universal Time) https://www.techonthenet.com/excel/formulas/isempty.php

#vba
star

Thu Jun 01 2023 09:46:24 GMT+0000 (Coordinated Universal Time) https://www.automateexcel.com/vba/call-sub-from-another-sub/

#vba
star

Thu Jun 01 2023 09:34:55 GMT+0000 (Coordinated Universal Time) https://learn.microsoft.com/en-us/office/troubleshoot/access/force-new-line-msgbox-message

#vba
star

Fri May 26 2023 04:22:37 GMT+0000 (Coordinated Universal Time) https://gitiho.com/blog/tong-hop-ky-tu-dac-biet-trong-viet-code-vba-nhat-dinh-phai-biet-7136.html

#vba
star

Fri May 26 2023 04:14:15 GMT+0000 (Coordinated Universal Time) https://blog.hocexcel.online/mot-code-vba-de-tim-dong-cuoi-cung-co-du-lieu-trong-excel.html

#vba
star

Mon May 08 2023 17:22:35 GMT+0000 (Coordinated Universal Time)

#sql #vba
star

Tue Nov 22 2022 04:02:13 GMT+0000 (Coordinated Universal Time) https://trumpexcel.com/vba-delete-row-excel/

#vba
star

Tue Nov 22 2022 03:46:41 GMT+0000 (Coordinated Universal Time) https://trumpexcel.com/vba-delete-row-excel/

#vba
star

Sat Oct 15 2022 09:08:35 GMT+0000 (Coordinated Universal Time) https://www.extendoffice.com/documents/excel/3725-excel-move-row-to-bottom.html

#vba
star

Tue Sep 13 2022 11:33:30 GMT+0000 (Coordinated Universal Time) https://www.extendoffice.com/documents/excel/1156-excel-insert-multiple-pictures.html

#vba
star

Thu Sep 08 2022 07:34:52 GMT+0000 (Coordinated Universal Time) https://analysistabs.com/excel-vba/copy-files-one-location-another-folder-directory/

#vba #excel
star

Sat Jul 23 2022 04:01:58 GMT+0000 (Coordinated Universal Time)

#vba
star

Sat Jul 23 2022 03:27:07 GMT+0000 (Coordinated Universal Time)

#vba
star

Wed Apr 27 2022 12:53:33 GMT+0000 (Coordinated Universal Time)

#vba
star

Tue Apr 12 2022 11:24:44 GMT+0000 (Coordinated Universal Time)

#vba
star

Thu Mar 17 2022 15:18:49 GMT+0000 (Coordinated Universal Time)

#vba
star

Thu Mar 03 2022 12:50:39 GMT+0000 (Coordinated Universal Time)

#vba
star

Thu Feb 24 2022 14:05:48 GMT+0000 (Coordinated Universal Time)

#vba
star

Thu Feb 24 2022 05:23:44 GMT+0000 (Coordinated Universal Time) https://www.thesmallman.com/looping-through-worksheets

#vba
star

Mon Feb 21 2022 13:09:56 GMT+0000 (Coordinated Universal Time) https://www.automateexcel.com/vba/sheets-worksheets

#vba
star

Mon Feb 21 2022 12:54:55 GMT+0000 (Coordinated Universal Time) https://www.extendoffice.com/documents/excel/3501-excel-jump-to-first-tab.html

#vba
star

Mon Feb 21 2022 03:40:58 GMT+0000 (Coordinated Universal Time)

#vba
star

Sun Feb 20 2022 10:50:38 GMT+0000 (Coordinated Universal Time)

#vba
star

Sun Feb 20 2022 03:25:19 GMT+0000 (Coordinated Universal Time)

#vba
star

Sun Feb 20 2022 03:03:59 GMT+0000 (Coordinated Universal Time)

#vba #vbs
star

Sun Feb 20 2022 02:10:22 GMT+0000 (Coordinated Universal Time) https://www.rondebruin.nl/win/s3/win026.htm

#vba
star

Tue Feb 15 2022 12:30:28 GMT+0000 (Coordinated Universal Time) https://www.access-programmers.co.uk/forums/threads/question-get-all-procedure-names-from-modules.169954/

#vba
star

Mon Feb 07 2022 18:08:40 GMT+0000 (Coordinated Universal Time)

#vba #excel
star

Wed Feb 02 2022 21:39:08 GMT+0000 (Coordinated Universal Time)

#excel #vba #macro
star

Mon Dec 13 2021 12:02:52 GMT+0000 (Coordinated Universal Time) https://bytes.com/topic/access/answers/961807-vba-auto-refresh-linked-table-manager-linked-tables

#vba
star

Thu Dec 09 2021 14:13:55 GMT+0000 (Coordinated Universal Time)

#vba
star

Tue Dec 07 2021 12:03:01 GMT+0000 (Coordinated Universal Time)

#vba #sql
star

Tue Dec 07 2021 11:29:55 GMT+0000 (Coordinated Universal Time)

#vba
star

Mon Nov 15 2021 10:49:03 GMT+0000 (Coordinated Universal Time)

#vba
star

Mon Nov 15 2021 10:48:44 GMT+0000 (Coordinated Universal Time)

#vba
star

Mon Nov 15 2021 10:48:27 GMT+0000 (Coordinated Universal Time)

#vba
star

Mon Nov 15 2021 08:41:09 GMT+0000 (Coordinated Universal Time)

#vba
star

Sun Nov 14 2021 18:26:20 GMT+0000 (Coordinated Universal Time)

#vba
star

Sun Nov 14 2021 13:14:05 GMT+0000 (Coordinated Universal Time)

#vba
star

Sun Nov 14 2021 08:49:44 GMT+0000 (Coordinated Universal Time)

#vba
star

Sun Nov 14 2021 08:30:20 GMT+0000 (Coordinated Universal Time)

#vba
star

Mon Sep 27 2021 07:18:02 GMT+0000 (Coordinated Universal Time)

#vba
star

Mon Jun 14 2021 13:49:22 GMT+0000 (Coordinated Universal Time)

#vba
star

Tue Jun 08 2021 16:03:17 GMT+0000 (Coordinated Universal Time)

#vba
star

Thu Mar 04 2021 15:24:04 GMT+0000 (Coordinated Universal Time)

#vba
star

Fri Feb 26 2021 04:08:24 GMT+0000 (Coordinated Universal Time)

#excel #vba

Save snippets that work with our extensions

Available in the Chrome Web Store Get Firefox Add-on Get VS Code extension