1.
Check marks of student if it is grater then 80
then distinction if it is grater then 60 but less than 80 then first division
if marks grater then 50 but less than 60 then second division if marks is greater
than 30 but less than 50 third division else filed and list marks in one cell
and filter on another cell and also show how many student are first division, second division, third division, distinction and failed in VBA.
Sub checkMarksOfStudent()
Dim ws As Worksheet
Dim wb As Workbook
Dim rng As Range
Dim obj As Variant
Dim f As Integer
Dim s As Integer
Dim dis As Integer
Dim fail As Integer
Dim th As Integer
On Error GoTo last
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet5")
Set rng = ws.Range("c2:c14")
For Each obj In rng
If obj.Value >= 80 Then
ws.Cells(obj.row, obj.Column + 1) =
"Distinction"
ElseIf obj.Value >= 60 And obj.Value
< 80 Then
ws.Cells(obj.row, obj.Column + 1) =
"First Division"
ElseIf obj.Value >= 50 And obj.Value
< 60 Then
ws.Cells(obj.row, obj.Column + 1) =
"Second Division"
ElseIf obj.Value < 50 And obj.Value
>= 30 Then
ws.Cells(obj.row, obj.Column + 1) =
"Third Division"
Else
ws.Cells(obj.row, obj.Column + 1) =
"Failed"
End If
Next
Set rng = ws.Range("D2:D14")
f = WorksheetFunction.CountIf(rng,
"First Division")
s = WorksheetFunction.CountIf(rng,
"Second Division")
th = WorksheetFunction.CountIf(rng,
"Third Division")
dis = WorksheetFunction.CountIf(rng,
"Distinction")
fail = WorksheetFunction.CountIf(rng,
"Failed")
ws.Range("H5") = f
ws.Range("H6") = s
ws.Range("H7") = th
ws.Range("H8") = dis
ws.Range("H9") = fail
If Err.Description <> ""
Then
MsgBox Err.Description, vbInformation
End If
End Sub
2.
Connection with data base in VBA.
Sub ConnectWithDatabase()
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim qStr As String
Dim ws As Worksheet
Dim wb As Workbook
Dim conString As String
Set wb = ThisWorkbook
Set ws = ActiveSheet
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
conString = "Provider=SQLOLEDB;Data
Source=AMBARISH;Initial Catalog=practice;Integrated Security=SSPI;"
qStr = "Select * from country"
con.Open (conString)
If con.State = adStateClosed Then
MsgBox "Connection not stablised from
database", vbInformation
Else
Set rs = con.Execute(qStr)
ws.Range("A1").CopyFromRecordset
rs
End If
End Sub
Sub ImpoertTextFile()
Dim FileNum As Integer
Dim dataLine As String
Dim arr() As String
Dim del As String
Dim obj As Variant
Dim count As Integer
FileNum = FreeFile()
Open
"C:\Users\ambarish\Desktop\ShowCase\New Text Document.txt" For Input
As #FileNum
del = InputBox("Inter delimiter",
vbInformation)
While Not EOF(FileNum)
Line Input #FileNum, dataLine ' read in data 1 line at a time
'
decide what to do with dataline,
'
depending on what processing you need to do for each case
MsgBox dataLine, vbInformation
arr = Split(dataLine, del)
For Each obj In arr
count = count + 1
MsgBox count & " "
& obj
Next
Wend
Close #FileNum
End Sub
4.
How count last row by using range.End and
range.Find method in VBA.
Sub LastRow()
Dim lstRow As Integer
Dim lstCol As Integer
lstRow = ActiveSheet.UsedRange.Rows.count
lstCol =
ActiveSheet.UsedRange.Columns.count
MsgBox "Used Last rows =" &
lstRow
MsgBox "Used Last columns ="
& lstCol
lstRow = ActiveSheet.UsedRange.row
lstCol = ActiveSheet.UsedRange.Column
MsgBox "Used Last row =" &
lstRow
lstRow =
Range("A1:D10").Find("USA").row
lstCol =
Range("A1:D10").Find("USA").Column
MsgBox "Find last row in selected
range =" & lstRow
MsgBox "Find last column in selected
rnage" & lstCol
End Sub
5.
Reverse string and print it in VBA.
Sub ReverseString()
Dim str As String
Dim arr() As String
Dim i As Integer
Dim j As Integer
Dim revArr() As String
str = InputBox("Enter a string for
reverse")
arr = Split(str, " ")
For i = 0 To UBound(arr)
MsgBox "element as " & i
& "=" & arr(i)
Next
ReDim revArr(UBound(arr))
j = UBound(arr)
For i = 0 To UBound(arr)
revArr(i) = arr(j)
j = j - 1
Next
For i = 0 To UBound(arr)
MsgBox "element as " & i
& "=" & revArr(i)
Next
End Sub
Sub AnotheWayOfDoing()
Dim str As String
Dim i As Integer
Dim j As Integer
Dim revStr As String
str = InputBox("Enter the string
")
MsgBox "String before reverse"
& str
revStr = StrReverse(str)
MsgBox "String after reverse"
& revStr
End Sub
6.
How to find repetition of character along with
the character in a string in VBA.
Sub FindRepitionOfCharcterInWord()
Dim str As String
Dim wCount As Integer
Dim chr As String
Dim i As Integer
Dim j As Integer
Dim count As Integer
str = InputBox("Enter String to be
revers")
For i = 1 To Len(str)
count = i
chr = Mid(str, i, 1)
For j = i To Len(str)
Debug.Print Mid(str, j, 1)
If chr = Mid(str, j, 1) Then
count = count + 1
MsgBox chr & "Character find
" & count
'Exit For
End If
Next
Next
End Sub
7.
How to how to print multiplication of array in
VBA.
Sub Multiplicatio()
Dim arr() As Variant
Dim arr2() As Variant
Dim arr1() As Variant
Dim i As Integer
Dim count As Integer
Dim j As Integer
arr = Array(1, 2)
arr1 = Array(3, 4)
ReDim arr2(UBound(arr) + UBound(arr1) + 1)
For i = 0 To 1
For j = 0 To 1
arr2(count) = arr(i) * arr1(j)
count = count + 1
Next
Next
For i = 0 To UBound(arr2)
MsgBox arr2(i)
Next
End Sub
8.
How import content of excel worksheet in to text
file in VBA.
Sub exportAsText()
Dim fso As FileSystemObject
Dim stream As TextStream
Dim rng As Range
Dim obj As Variant
Set rng = Range("A1:C14")
Set fso = New FileSystemObject
Set stream =
fso.OpenTextFile("C:\Users\ambarish\Desktop\Test1.txt", ForWriting,
True)
For Each obj In rng
stream.WriteLine obj.Value
Next
End Sub
9.
How to protect and unprotect worksheet and
workbook single multiple in VBA.
Sub ProtectSingleworksheet()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
ws.Protect True
End Sub
Sub ProtectAllWorksheet()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
ws.Protect False
Next
End Sub
Sub UnProtectSingleworksheet()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
ws.Protect False
End Sub
Sub UnProtectAllWorksheet()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
ws.Unprotect
Next
End Sub
10.
How to hide and unhide worksheet single multiple
in VBA.
Sub HideUnhideSingleWorksheet()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
ws.Visible = xlSheetHidden
End Sub
Dim ws As Worksheet
Dim opt As String
Dim wb As Workbook
Set wb = ThisWorkbook
opt = InputBox("Enter you option Y for
hide all woerksheet/N for unhide all excel worksheet")
If opt = "Y" Then
For Each ws In wb.Sheets
If ws.Name <> ActiveSheet.Name Then
ws.Visible = xlSheetHidden
End If
Next
ElseIf opt = "N" Then
For Each ws In wb.Worksheets
If ws.Name <> ActiveSheet.Name Then
ws.Visible = xlSheetVisible
End If
Next
End If
End Sub
