Scribd
Upload
90 views

VBA Code

This document contains definitions for several VBA functions including: 1) A function that returns the last character of a string or a message if the string is too short. 2) A function that returns the name of the student with the highest marks from two ranges. 3) Functions that validate personal identification codes by checking a verification character. 4) Functions related to calculating leap years and the number of days in a year. 5) Several functions for calculating the Fibonacci sequence using different techniques. 6) A function that doubles the values in a 2D array. 7) Functions that find the minimum value and count of occurrences in a range.

Uploaded by

Ragul
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
90 views

VBA Code

This document contains definitions for several VBA functions including: 1) A function that returns the last character of a string or a message if the string is too short. 2) A function that returns the name of the student with the highest marks from two ranges. 3) Functions that validate personal identification codes by checking a verification character. 4) Functions related to calculating leap years and the number of days in a year. 5) Several functions for calculating the Fibonacci sequence using different techniques. 6) A function that doubles the values in a 2D array. 7) Functions that find the minimum value and count of occurrences in a range.

Uploaded by

Ragul
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 4

Option Explicit

1. Message if string too short

Function seclast(str As String) As String


If (Len(str) >= 2) Then
seclast = Mid(str, Len(str) - 1, 1)
Else
seclast = "Sorry..String too short"
End If
End Function

2. Topper function

Function Topper(Names As Range, marks As Range) As String


Dim highest As Integer
highest = WorksheetFunction.Max(marks)
Topper = WorksheetFunction.Index(Names, WorksheetFunction.Match(highest, marks, 0))
End Function

3. OK NOT OK FUNCTION

Function VPC(PC As String) As String


Dim Gcd As String, sum As Integer, i As Integer, Ccd As Integer

Gcd = Right(PC, 1)
'The next 4 lines compute the sumproduct
sum = 0
For i = 1 To 9
sum = sum + (10 - i) * Val(Mid(PC, i, 1))
Next i
Ccd = sum Mod 11
'Compare Gcd and Ccd
If Ccd = 10 Then
If Gcd = "X" Then
VPC = "Ok"
Else
VPC = "NotOk"
End If
Else
If Asc(Gcd) = Asc(Ccd) Then
VPC = "Ok"
Else
VPC = "NotOk"
End If
End If

End Function

4. Function VPCA(PC As String) As String


Dim Gcd As String, sum As Integer, i As Integer, Ccd As Integer

Gcd = Right(PC, 1)
'The next 4 lines compute the sumproduct
sum = 0
For i = 1 To 9
sum = sum + (10 - i) * Val(Mid(PC, i, 1))
Next i
Ccd = sum Mod 11
'Compare Gcd and Ccd
If Gcd = "X" Then
If Ccd = 10 Then
VPCA = "Ok"
Else
VPCA = "NotOk"
End If
Else
If Val(Gcd) <> Ccd Then
VPCA = "NotOk"
Else
VPCA = "Ok"
End If
End If

End Function

5.Function isleap(Yr As Integer) As Boolean


isleap = (Yr Mod 400 = 0) Or ((Yr Mod 4 = 0) And Not (Yr Mod 100 = 0) And Not (Yr
Mod 400 = 0))
End Function

Function daysyear(year As Integer) As Integer


If isleap(year) = True Then
daysyear = 366
Else
daysyear = 365
End If
End Function

Function FIBR(N As Integer) As Long


If N = 1 Then
FIBR = 0
Else
If N = 2 Then
FIBR = 1
Else
FIBR = FIBR(N - 1) + FIBR(N - 2)
End If
End If
End Function
Function FIBRSel(N As Integer) As Long
Select Case N
Case 1
FIBRSel = 0
Case 2
FIBRSel = 1
Case Else
FIBRSel = FIBRSel(N - 1) + FIBRSel(N - 2)
End Select
End Function

Function FIB(N As Integer) As Long


Dim i As Integer, FPP As Long, FP As Long, F As Long
Select Case N
Case 1
FIB = 0
Case 2
FIB = 1
Case Else
FPP = 0
FP = 1
For i = 3 To N
F = FP + FPP
FPP = FP
FP = F
Next i
FIB = F
End Select
End Function
Function FIBDo(N As Integer) As Long
Dim i As Integer, FPP As Long, FP As Long, F As Long
Select Case N
Case 1
FIBDo = 0
Case 2
FIBDo = 1
Case Else
FPP = 0
FP = 1
i = 3
Do While i <= N
F = FP + FPP
FPP = FP
FP = F
i = i + 1
Loop
FIBDo = F
End Select
End Function

Sub Intro()
Range("A1") = 15442
ActiveCell.Font.Bold = True
ActiveCell.Interior.Color = vbYellow
End Sub

10. Function Mtwice(InpMat As Range)


Dim i As Integer, j As Integer, r As Integer, c As Integer
r = InpMat.Rows.Count
c = InpMat.Columns.Count
Dim OutMat() As Integer
ReDim OutMat(1 To r, 1 To c)
For i = 1 To r
For j = 1 To c
OutMat(i, j) = 2 * InpMat(i, j)
Next j
Next i
Mtwice = OutMat
End Function

Function minnmin(Given As Range)


Dim r As Integer, c As Integer, i As Integer, j As Integer
Dim result(1 To 2) As Integer
r = Given.Rows.Count
c = Given.Columns.Count
result(1) = Given(1, 1)
result(2) = 0
'finding the minimum value
For i = 1 To r
For j = 1 To c
If (Given(i, j) < result(1)) Then
result(1) = Given(i, j)
End If
Next j
Next i
'finding the number of times minimum occurs
For i = 1 To r
For j = 1 To c
If Given(i, j) = result(1) Then
result(2) = result(2) + 1
End If
Next j
Next i

minnmin = result
End Function

Function minnminV(Given As Range)


Dim r As Integer, c As Integer, i As Integer, j As Integer
Dim result(1 To 2, 1 To 1) As Integer
r = Given.Rows.Count
c = Given.Columns.Count
result(1, 1) = Given(1, 1)
result(2, 1) = 0
'finding the minimum value
For i = 1 To r
For j = 1 To c
If (Given(i, j) < result(1, 1)) Then
result(1, 1) = Given(i, j)
End If
Next j
Next i
'finding the number of times minimum occurs
For i = 1 To r
For j = 1 To c
If Given(i, j) = result(1, 1) Then
result(2, 1) = result(2, 1) + 1
End If
Next j
Next i

minnminV = result
End Function

You might also like