0% found this document useful (0 votes)
48 views

VBA Texts

The document contains 84 VBA code scenarios that demonstrate various Excel and VBA functions and concepts like filtering data, performing calculations, selecting cells and ranges, working with workbooks and worksheets, copying and pasting data, and defining custom functions. The scenarios cover a wide range of commonly used tasks and programming structures in VBA like loops, if/then statements, and select case statements.

Uploaded by

panjumuttaai
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
0% found this document useful (0 votes)
48 views

VBA Texts

The document contains 84 VBA code scenarios that demonstrate various Excel and VBA functions and concepts like filtering data, performing calculations, selecting cells and ranges, working with workbooks and worksheets, copying and pasting data, and defining custom functions. The scenarios cover a wide range of commonly used tasks and programming structures in VBA like loops, if/then statements, and select case statements.

Uploaded by

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

Sub SCeanrio1()

Selection.AutoFilter Field:=1, Criteria1:="East"


End Sub
Sub Scenario2()
Selection.AutoFilter
End Sub
Sub SCenario3()
Selection.AutoFilter Field:=9, Criteria1:=">50000"
End Sub
Sub Scenario4()
Selection.AutoFilter Field:=1, Criteria1:="East", Operator:=xlOr,
Criteria2:="North"
End Sub
Sub Scenario5()
Selection.AutoFilter Field:=9, Criteria1:=">50000", Operator:=xlAnd,
Criteria2:="<75000"
End Sub
Sub SCeanrio6()
Selection.AutoFilter Field:=1, Criteria1:="East"
Selection.AutoFilter Field:=9, Criteria1:=">50000"
End Sub
Sub SCenario7()
Selection.AutoFilter Field:=4, Criteria1:="S*"
End Sub

Sub Scenario8()
'Calculation happens in Excel
ActiveCell.Value = "=SUM(D3:D7)"
End Sub
Sub SCenario9()
' Calculation happens in VBA
ActiveCell.Value = WorksheetFunction.Sum(Range("D3:D7"))
End Sub
Sub SCenario10()
If WorksheetFunction.Sum(Range("D3:D7")) > 50000 Then
MsgBox "Great Deal"
Else
MsgBox "Ok Deal"
End If
End Sub
Sub SCenario11()
ActiveCell.Value = "=SUMIF(A3:A7,C12,D3:D7)"
End Sub
Sub SCenario12()
ActiveCell.Value = WorksheetFunction.SumIf(Range("A3:A7"), ActiveCell.Offset(0,
-1), Range("D3:D7"))
End Sub
Sub SCenario13()
ActiveCell.Value = "=VLOOKUP(C15,A3:D7,4,FALSE)"
End Sub
Sub SCenario14()
ActiveCell.Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -1),
Range("A3:D7"), 4, False)
End Sub
###################################################
Sub Scenario1()
Dim i As Double
For i = 1 To 10
Workbooks.Add
Next
End Sub
Sub Scenario2()
Dim ProceedStatus As String
ProceedStatus = InputBox("Do you want to create a new workbook ? yes / no")

Do While LCase(ProceedStatus) = "yes"


Workbooks.Add
ProceedStatus = InputBox("Do you want to create a new workbook ? yes / no")
Loop
End Sub
Sub Scenario3()
Workbooks.Close
End Sub

Sub Scenario4()
MsgBox Workbooks.Count
End Sub

Sub Scenario5()
Workbooks.Open ReadOnly:=True, Password:="123", Filename:="C:\00\Sample.xlsx"
End Sub

Sub Scenario6()
Workbooks("Sample.xlsx").Activate
End Sub
Sub Scenario7()
ThisWorkbook.Activate
End Sub
Sub Scenario8()
Dim i As Double
For i = 1 To Workbooks.Count
Workbooks(i).Activate
MsgBox "Activated"
Next
End Sub
Sub Scenario9()
Workbooks("Sample.xlsx").Close
End Sub
Sub Scenario10()
ActiveWorkbook.Close
End Sub
Sub Scenario11()
ThisWorkbook.Close
End Sub
Sub Scenario12()
MsgBox ActiveWorkbook.Name
End Sub
Sub Scenario13()
MsgBox ThisWorkbook.Name
End Sub
Sub Scenario14()
Dim i As Double
For i = 1 To Workbooks.Count
Workbooks(i).Activate
MsgBox Workbooks(i).Name
MsgBox Workbooks(i).Path
MsgBox Workbooks(i).FullName
Next
End Sub
Sub Scenario15()
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Sample2.xlsx"
End Sub
Sub Scenario16()
Dim i As Double
For i = 1 To 10
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\EG" & i & ".xlsx"
ActiveWorkbook.Close
Next
End Sub

Sub Scenario17()
Worksheets.Add
End Sub
Sub Scenario18()
Worksheets.Add After:=ActiveSheet
End Sub
Sub Scenario19()
Worksheets.Add before:=Worksheets(1)
End Sub
Sub Scenario20()
Worksheets.Add After:=Worksheets("Sample")
End Sub
Sub Scenario21()
MsgBox Worksheets.Count
End Sub
Sub Scenario22()
Worksheets.Add After:=Worksheets(Worksheets.Count)
End Sub
Sub Scenario23()
Worksheets(1).Select
End Sub
Sub Scenario24()
Worksheets("Sample").Select
End Sub
Sub Scenario25()
Worksheets(Worksheets.Count).Select
End Sub
Sub Scenario26()
Dim i As Double
For i = 1 To Worksheets.Count
Worksheets(i).Select
MsgBox "Selected"
Next
End Sub
Sub Scenario27()
MsgBox ActiveSheet.Name
End Sub
Sub Scenario28()
Dim i As Double
For i = 1 To Worksheets.Count
Worksheets(i).Select
MsgBox Worksheets(i).Name
Next
End Sub
Sub Scenario29()
ActiveSheet.Name = "Sample10"
End Sub
Sub Scenario30()
Dim i As Double
For i = 1 To Worksheets.Count
Worksheets(i).Name = "EG" & i
Next
End Sub
Sub Scenario31()
ActiveSheet.Visible = False
End Sub
Sub Scenario32()
Worksheets("EG4").Visible = False
End Sub
Sub Scenario33()
Dim i As Double
For i = 1 To Worksheets.Count
Worksheets(i).Visible = True
Next
End Sub
Sub Scenario34()
Application.DisplayAlerts = False
ActiveSheet.Delete
End Sub
Sub Scenario35()
Application.DisplayAlerts = False
Worksheets("EG5").Delete
End Sub
Sub Scenario36()
Worksheets("EG3").Copy
End Sub
Sub Scenario37()
Worksheets("EG3").Copy After:=Worksheets(Worksheets.Count)
End Sub
Sub Scenario38()
ActiveSheet.Move
End Sub
Sub Scenario39()
Worksheets(Worksheets.Count).Move before:=Worksheets(1)
End Sub

Sub Scenario40()
ActiveCell.Value = "Excelgoodies"
End Sub
Sub Scenario41()
Range("B15:D20").Value = "Excelgoodies"
End Sub
Sub Scenario42()
Selection.Value = "Excelgoodies"
End Sub
Sub Scenario43()
ActiveCell.EntireRow.Value = "Excelgoodies"
End Sub
Sub Sceanrio44()
Selection.ClearContents
End Sub
Sub Scenario45()
Selection.ClearFormats
End Sub
Sub Scenario46()
Selection.Clear
End Sub

Sub Scenario47()
ActiveCell.Offset(2, 0).Select
End Sub
Sub Scenario48()
ActiveCell.Offset(0, 2).Select
End Sub
Sub Scenario49()
ActiveCell.Offset(-2, 0).Select
End Sub
Sub Scenario50()
ActiveCell.Offset(0, -2).Select
End Sub
Sub Scenario51()
ActiveCell.End(xlDown).Select
End Sub
Sub Scenario52()
ActiveCell.End(xlToRight).Select
End Sub
Sub Scenario53()
ActiveCell.End(xlUp).Select
End Sub
Sub Scenario54()
ActiveCell.End(xlToLeft).Select
End Sub
Sub Scenario55()
ActiveCell.Offset(0, -1).Select
ActiveCell.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.End(xlUp).Select
End Sub
Sub Scenario56()
ActiveCell.Offset(0, -1).End(xlDown).Offset(0, 1).End(xlUp).Select
End Sub
Sub Scenario57()
ActiveCell.Offset(100000, 0).Select
ActiveCell.End(xlUp).Select
End Sub
Sub Scenario58()
ActiveCell.Offset(100000, 0).End(xlUp).Select
End Sub

Sub Scenario59()
Range("B5:D10").Select
End Sub
Sub Scenario60()
Range("B5", "D10").Select
End Sub
Sub Scenario61()
Range(ActiveCell, ActiveCell.Offset(2, 0)).Select
End Sub
Sub Scenario62()
Range(ActiveCell, ActiveCell.Offset(0, 2)).Select
End Sub
Sub Scenario63()
Range(ActiveCell, ActiveCell.End(xlDown)).Select
End Sub
Sub Scenario64()
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
End Sub
Sub Scenario65()
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
End Sub

Sub Scenario66()
Range("B:D").Select
End Sub
Sub Scenario67()
Columns(2).Select
End Sub
Sub Scenario68()
Range(Columns(2), Columns(5)).Select
End Sub
Sub Scenario69()
Selection.EntireColumn.Select
End Sub
Sub Scenario70()
Range("2:5").Select
End Sub
Sub Scenario71()
Rows(2).Select
End Sub
Sub Scenario72()
Range(Rows(2), Rows(5)).Select
End Sub
Sub Scenario73()
Selection.EntireRow.Select
End Sub
Sub Scenario74()
Cells.Select
End Sub

Sub Scenario75()
Selection.SpecialCells(xlCellTypeBlanks).Select
End Sub
Sub Scenario76()
Selection.SpecialCells(xlCellTypeFormulas).Select
End Sub
Sub Scenario77()
Selection.SpecialCells(xlCellTypeConstants).Select
End Sub

Sub Scenario78()
Selection.Copy
Range("G13").PasteSpecial Paste:=xlPasteValues
Range("G13").PasteSpecial Paste:=xlPasteFormats
Range("G13").PasteSpecial Paste:=xlPasteColumnWidths
Application.CutCopyMode = False
End Sub
Sub Scenario79()
Range("D12").Copy
Range("D14:D18").PasteSpecial Paste:=xlPasteValues,
Operation:=xlPasteSpecialOperationAdd
Application.CutCopyMode = False
End Sub
Sub Scenario80()
Selection.Copy
Range("B20").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.CutCopyMode = False
End Sub
Sub Scenario81()
Selection.Cut
Range("B24").Select
ActiveSheet.Paste
End Sub
Sub Scenario82()
Selection.EntireRow.Select
Selection.Copy
Selection.EntireRow.Insert
Application.CutCopyMode = False
End Sub
############################################################
Function EGCalculateSalesAmount(Rate As Double, Qty As Double) As Double
EGCalculateSalesAmount = Rate * Qty
End Function

Function EGGetSeniority(Age As Integer) As String


Select Case Age
Case Is < 25
EGGetSeniority = "Junior"
Case 25 To 35
EGGetSeniority = "Executive"
Case 35 To 45
EGGetSeniority = "Manager"
Case 45 To 55
EGGetSeniority = "Sr Manager"
Case Is > 55
EGGetSeniority = "CXO"
End Select
End Function

Function EGCalculateDiscount(Region As String, SalesAmount As Double) As Double

If SalesAmount <= 50000 Then


Select Case LCase(Region)
Case "east"
EGCalculateDiscount = SalesAmount * 0.02
Case "west"
EGCalculateDiscount = SalesAmount * 0.04
Case "north"
EGCalculateDiscount = SalesAmount * 0.06
Case "south"
EGCalculateDiscount = SalesAmount * 0.08
End Select
Else
Select Case LCase(Region)
Case "east"
EGCalculateDiscount = SalesAmount * 0.12
Case "west"
EGCalculateDiscount = SalesAmount * 0.14
Case "north"
EGCalculateDiscount = SalesAmount * 0.16
Case "south"
EGCalculateDiscount = SalesAmount * 0.18
End Select
End If

End Function

Function EGCalculateShippingCharges(ShipToCountry As String, Weight As Double) As


Double

Select Case LCase(ShipToCountry)


Case "us"
Select Case Weight
Case Is < 250
EGCalculateShippingCharges = Weight * 5
Case 250 To 500
EGCalculateShippingCharges = Weight * 4
Case Is > 500
EGCalculateShippingCharges = Weight * 3
End Select
Case "uk"
Select Case Weight
Case Is < 250
EGCalculateShippingCharges = Weight * 6
Case 250 To 500
EGCalculateShippingCharges = Weight * 5
Case Is > 500
EGCalculateShippingCharges = Weight * 4
End Select
Case "france"
Select Case Weight
Case Is < 250
EGCalculateShippingCharges = Weight * 7
Case 250 To 500
EGCalculateShippingCharges = Weight * 6
Case Is > 500
EGCalculateShippingCharges = Weight * 5
End Select
Case Else
Select Case Weight
Case Is < 250
EGCalculateShippingCharges = Weight * 8
Case 250 To 500
EGCalculateShippingCharges = Weight * 7
Case Is > 500
EGCalculateShippingCharges = Weight * 6
End Select
End Select

End Function

Function EGCalculateBusFare(BusCategory As String, PassengerCategory As String,


Distance As Double) As Double
Select Case LCase(BusCategory)
Case "general"
If LCase(PassengerCategory) = "adult" Then
Select Case Distance
Case Is < 50
EGCalculateBusFare = Distance * 0.5
Case 50 To 100
EGCalculateBusFare = Distance * 0.4
Case Is > 100
EGCalculateBusFare = Distance * 0.3
End Select
Else
Select Case Distance
Case Is < 50
EGCalculateBusFare = Distance * 0.25
Case 50 To 100
EGCalculateBusFare = Distance * 0.2
Case Is > 100
EGCalculateBusFare = Distance * 0.15
End Select
End If
Case "luxury"
Select Case Distance
Case Is < 50
EGCalculateBusFare = Distance * 0.8
Case 50 To 100
EGCalculateBusFare = Distance * 0.4
Case Is > 100
EGCalculateBusFare = Distance * 0.25
End Select
Case "ac"
Select Case Distance
Case Is < 50
EGCalculateBusFare = Distance * 2
Case 50 To 100
EGCalculateBusFare = Distance * 1.5
Case Is > 100
EGCalculateBusFare = Distance * 1
End Select
End Select
End Function

Function EGCalculateTrainFare(FromStation As String, ToStation As String) As Double


Select Case LCase(FromStation)
Case "koyembedu"
Select Case LCase(ToStation)
Case "koyembedu"
EGCalculateTrainFare = 0
Case "cmbt"
EGCalculateTrainFare = 10
Case "arumbakkam"
EGCalculateTrainFare = 20
Case "vadapalani"
EGCalculateTrainFare = 30
End Select
Case "cmbt"
Select Case LCase(ToStation)
Case "koyembedu"
EGCalculateTrainFare = 10
Case "cmbt"
EGCalculateTrainFare = 0
Case "arumbakkam"
EGCalculateTrainFare = 10
Case "vadapalani"
EGCalculateTrainFare = 20
End Select
Case "arumbakkam"
Select Case LCase(ToStation)
Case "koyembedu"
EGCalculateTrainFare = 20
Case "cmbt"
EGCalculateTrainFare = 10
Case "arumbakkam"
EGCalculateTrainFare = 0
Case "vadapalani"
EGCalculateTrainFare = 10
End Select
Case "vadapalani"
Select Case LCase(ToStation)
Case "koyembedu"
EGCalculateTrainFare = 30
Case "cmbt"
EGCalculateTrainFare = 20
Case "arumbakkam"
EGCalculateTrainFare = 10
Case "vadapalani"
EGCalculateTrainFare = 0
End Select
End Select
End Function

Function EGCalculateEBBill(ConsumerType As String, UnitsConsumed As Double) As


Double
Select Case LCase(ConsumerType)
Case "domestic"
Select Case UnitsConsumed
Case Is < 100
EGCalculateEBBill = (UnitsConsumed * 1) + 20
Case 100 To 200
EGCalculateEBBill = (UnitsConsumed * 1.5) + 20
Case 200 To 500
EGCalculateEBBill = (UnitsConsumed * 3) + 30
Case Is > 500
EGCalculateEBBill = (UnitsConsumed * 5.75) + 40
End Select
Case "commercial"
If UnitsConsumed <= 100 Then
EGCalculateEBBill = (UnitsConsumed * 4.3) + 100
Else
EGCalculateEBBill = (UnitsConsumed * 7) + 100
End If
Case "cottage"
If UnitsConsumed <= 500 Then
EGCalculateEBBill = 0
Else
EGCalculateEBBill = (UnitsConsumed * 4)
End If
Case Else
EGCalculateEBBill = (UnitsConsumed * 5.5)
End Select
End Function

Function EGEBBill(LYConsumption As Double, CPConsumption As Double) As Double


Select Case LYConsumption
Case Is <= 900
Select Case CPConsumption
Case 1 To 50
EGEBBill = CPConsumption * 1.45
Case 51 To 100
EGEBBill = CPConsumption * 2.6
Case 101 To 200
EGEBBill = CPConsumption * 3.6
Case Is > 200
EGEBBill = CPConsumption * 6.9
End Select
Case 900 To 2700
Select Case CPConsumption
Case 1 To 100
EGEBBill = CPConsumption * 2.6
Case 101 To 200
EGEBBill = CPConsumption * 3.6
Case 201 To 300
EGEBBill = CPConsumption * 6.9
Case Is > 300
EGEBBill = CPConsumption * 7.75
End Select
Case Is > 2700
Select Case CPConsumption
Case 1 To 50
EGEBBill = CPConsumption * 2.6
Case 51 To 100
EGEBBill = CPConsumption * 3.25
Case 101 To 200
EGEBBill = CPConsumption * 5.26
Case 201 To 300
EGEBBill = CPConsumption * 6.9
Case 301 To 400
EGEBBill = CPConsumption * 7.75
Case 401 To 500
EGEBBill = CPConsumption * 8.27
Case Is > 500
EGEBBill = CPConsumption * 8.8
End Select
End Select
End Function

Function EGCheckLoanStatus1(CreditRating As Integer, OwnHouse As String,


AnnualIncome As Double, Occupation As String, _
MaritalStatus As String) As String

If CreditRating > 850 Then


EGCheckLoanStatus1 = "Eligible"
Else
If LCase(OwnHouse) = "yes" Then
EGCheckLoanStatus1 = "Eligible"
Else
If AnnualIncome > 1200000 Then
EGCheckLoanStatus1 = "Eligible"
Else
If CreditRating > 750 And AnnualIncome > 800000 Then
EGCheckLoanStatus1 = "Eligible"
Else
If CreditRating > 750 And LCase(Occupation) = "salaried" Then
EGCheckLoanStatus1 = "Eligible"
Else
If AnnualIncome > 800000 And LCase(MaritalStatus) = "single"
Then
EGCheckLoanStatus1 = "Eligible"
Else
EGCheckLoanStatus1 = "Not Eligible"
End If
End If
End If
End If
End If
End If

End Function

Function EGCheckLoanStatus2(CreditRating As Integer, OwnHouse As String,


AnnualIncome As Double, Occupation As String, _
MaritalStatus As String) As String

If CreditRating > 850 Then


EGCheckLoanStatus2 = "Eligible"
Exit Function
End If

If AnnualIncome > 1200000 Then


EGCheckLoanStatus2 = "Eligible"
Exit Function
End If

If LCase(OwnHouse) = "yes" Then


EGCheckLoanStatus2 = "Eligible"
Exit Function
End If

If CreditRating > 750 And AnnualIncome > 800000 Then


EGCheckLoanStatus2 = "Eligible"
Exit Function
End If

If CreditRating > 750 And LCase(Occupation) = "salaried" Then


EGCheckLoanStatus2 = "Eligible"
Exit Function
End If

If AnnualIncome > 800000 And LCase(MaritalStatus) = "single" Then


EGCheckLoanStatus2 = "Eligible"
Exit Function
End If
EGCheckLoanStatus2 = "Not Eligible"

End Function

Function EGCheckLoanStatus3(CreditRating As Integer, OwnHouse As String,


AnnualIncome As Double, Occupation As String, _
MaritalStatus As String) As String

EGCheckLoanStatus3 = "Not Eligible"

If CreditRating > 850 Then


EGCheckLoanStatus3 = "Eligible"
End If

If AnnualIncome > 1200000 Then


EGCheckLoanStatus3 = "Eligible"
End If

If LCase(OwnHouse) = "yes" Then


EGCheckLoanStatus3 = "Eligible"
End If

If CreditRating > 750 And AnnualIncome > 800000 Then


EGCheckLoanStatus3 = "Eligible"
End If

If CreditRating > 750 And LCase(Occupation) = "salaried" Then


EGCheckLoanStatus3 = "Eligible"
End If

If AnnualIncome > 800000 And LCase(MaritalStatus) = "single" Then


EGCheckLoanStatus3 = "Eligible"
End If

End Function

Function EGCheckLoanStatus4(CreditRating As Integer, OwnHouse As String,


AnnualIncome As Double, Occupation As String, _
MaritalStatus As String) As String

Select Case True


Case (CreditRating > 850)
EGCheckLoanStatus4 = "Eligible"
Case (AnnualIncome > 1200000)
EGCheckLoanStatus4 = "Eligible"
Case (LCase(OwnHouse) = "yes")
EGCheckLoanStatus4 = "Eligible"
Case (CreditRating > 750 And AnnualIncome > 800000)
EGCheckLoanStatus4 = "Eligible"
Case (CreditRating > 750 And LCase(Occupation) = "salaried")
EGCheckLoanStatus4 = "Eligible"
Case (AnnualIncome > 800000 And LCase(MaritalStatus) = "single")
EGCheckLoanStatus4 = "Eligible"
Case Else
EGCheckLoanStatus4 = "Not Eligible"
End Select
End Function

Function EGCheckLoanStatus5(CreditRating As Integer, OwnHouse As String,


AnnualIncome As Double, Occupation As String, _
MaritalStatus As String) As String

If (CreditRating > 850) Or (AnnualIncome > 1200000) Or (LCase(OwnHouse) = "yes") Or


_
(CreditRating > 750 And AnnualIncome > 800000) Or (CreditRating > 750 And
LCase(Occupation) = "salaried") Or _
(AnnualIncome > 800000 And LCase(MaritalStatus) = "single") Then

EGCheckLoanStatus5 = "Eligible"
Else
EGCheckLoanStatus5 = "Not Eligible"
End If

End Function
########################################################
Function EGCalculateEBBill(ConsumerType As String, UnitsConsumed As Double) As
Double
Select Case LCase(ConsumerType)
Case "domestic"
Select Case UnitsConsumed
Case Is < 100
EGCalculateEBBill = UnitsConsumed * 1 + 20
Case 100 To 200
EGCalculateEBBill = UnitsConsumed * 1.5 + 20
Case 200 To 500
EGCalculateEBBill = UnitsConsumed * 3 + 30
Case Is > 500
EGCalculateEBBill = UnitsConsumed * 5.75 + 40
End Select
Case "commercial"
If UnitsConsumed < 100 Then
EGCalculateEBBill = UnitsConsumed * 4.3 + 100
Else
EGCalculateEBBill = UnitsConsumed * 7 + 100
End If
Case "cottage"
If UnitsConsumed < 500 Then
EGCalculateEBBill = 0
Else
EGCalculateEBBill = UnitsConsumed * 4
End If
Case Else
EGCalculateEBBill = UnitsConsumed * 5.5
End Select
End Function

Function EGGetEBBill(LYConsumption As Double, CPConsumption As Double) As Double


Select Case LYConsumption
Case Is < 900
Select Case CPConsumption
Case Is <= 50
EGGetEBBill = CPConsumption * 1.45
Case 50 To 100
EGGetEBBill = CPConsumption * 2.6
Case 100 To 200
EGGetEBBill = CPConsumption * 3.6
Case Is > 200
EGGetEBBill = CPConsumption * 6.9
End Select
Case 900 To 2700
Select Case CPConsumption
Case Is < 100
EGGetEBBill = CPConsumption * 2.6
Case 100 To 200
EGGetEBBill = CPConsumption * 3.6
Case 200 To 300
EGGetEBBill = CPConsumption * 6.9
Case Is > 300
EGGetEBBill = CPConsumption * 7.75
End Select
Case Is > 2700
Select Case CPConsumption
Case Is <= 50
EGGetEBBill = CPConsumption * 2.6
Case 50 To 100
EGGetEBBill = CPConsumption * 3.25
Case 100 To 200
EGGetEBBill = CPConsumption * 5.26
Case 200 To 300
EGGetEBBill = CPConsumption * 6.9
Case 300 To 400
EGGetEBBill = CPConsumption * 7.75
Case 400 To 500
EGGetEBBill = CPConsumption * 8.27
Case Is > 500
EGGetEBBill = CPConsumption * 8.8
End Select
End Select
End Function
##########################################################
Dim EmployeeName As String
Sub Scenario1()
EmployeeName = InputBox("Enter Employee Name")

Dim i As Double

For i = 1 To 10
MsgBox i
MsgBox EmployeeName
Next

End Sub
Sub Scenario2()
EmployeeName = InputBox("Enter Employee Name")

Dim i As Double

For i = 10 To 20
MsgBox i
MsgBox EmployeeName
Next

End Sub
Sub Scenario3()
EmployeeName = InputBox("Enter Employee Name")

Dim i As Double

For i = 1 To 10 Step 2
MsgBox i
MsgBox EmployeeName
Next

End Sub
Sub Scenario4()
EmployeeName = InputBox("Enter Employee Name")

Dim i As Double

For i = 10 To 1 Step -1
MsgBox i
MsgBox EmployeeName
Next

End Sub

Sub Scenario5()
EmployeeName = InputBox("Enter Employee Name")

Dim ProceedStatus As String


ProceedStatus = InputBox("Do you want to display employee name ? yes / no")

Do While LCase(ProceedStatus) = "yes"


MsgBox EmployeeName
ProceedStatus = InputBox("Do you want to display employee name ? yes / no")
Loop

End Sub
########################################################

Sub StaticProgrammingApproch()
Worksheets("Summary").Select
Range("C3:C8").Select
Selection.ClearContents
Range("C3").Select

Worksheets("Jan").Select
Range("C8").Select
Selection.Copy
Worksheets("Summary").Select
Range("C3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Worksheets("Feb").Select
Range("C8").Select
Selection.Copy
Worksheets("Summary").Select
Range("C4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
Sub DynamicProgrammingApproch()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Worksheets("Summary").Select
Range("C3:C8").Select
Selection.ClearContents
Range("C3").Select

Dim i As Double
For i = 2 To Worksheets.Count
Worksheets(i).Select
Range("C8").Select
Selection.Copy
Worksheets("Summary").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Next
End Sub
##########################################
Sub Static_Programming()
Worksheets("Summary").Select
Range("C3:C8").ClearContents
Range("C3").Select

Worksheets("Jan").Select
Range("C8").Copy
Worksheets("Summary").Select
Range("C3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Worksheets("Feb").Select
Range("C8").Copy
Worksheets("Summary").Select
Range("C4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Worksheets("Mar").Select
Range("C8").Copy
Worksheets("Summary").Select
Range("C5").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub

Sub Dynamic_Programming()
Worksheets("Summary").Select
Range("C3:C8").ClearContents
Range("C3").Select

Dim i As Integer
For i = 2 To Worksheets.Count
Worksheets(i).Select
Range("C8").Copy
Worksheets("Summary").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Next
End Sub
##########################################
Sub Static_Programming()

Worksheets("Summary").Select
Range("C3:H7").ClearContents
Range("C3").Select

Worksheets("Jan").Select
Range("C3:C7").Copy
Worksheets("Summary").Select
Range("C3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Worksheets("Feb").Select
Range("C3:C7").Copy
Worksheets("Summary").Select
Range("D3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub

Sub Dynamic_Programming()
Worksheets("Summary").Select
Range("C3:H7").ClearContents
Range("C3").Select

Dim i As Integer
For i = 2 To Worksheets.Count
Worksheets(i).Select
Range("C3:C7").Copy
Worksheets("Summary").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveCell.Offset(0, 1).Select
Next
End Sub
###################################################

Sub Dynamic_Programming()
Worksheets("Summary").Select
Range("C3:C8").ClearContents
Range("C3").Select

Dim i As Integer
For i = 2 To Worksheets.Count
Worksheets(i).Select
Range("C100000").End(xlUp).Copy
Worksheets("Summary").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Next
End Sub
#######################################################

Sub Dynamic_Programming()
Worksheets("Summary").Select
Range("C3:C8").ClearContents
Range("C3").Select

Dim i As Integer
For i = 2 To Worksheets.Count
Worksheets(i).Select
Cells.Find(What:="Total").Offset(0, 1).Copy
Worksheets("Summary").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Next
End Sub
######################################################

Sub Dynamic_Programming()
Worksheets("Summary").Select
Range("C3:C8").ClearContents
Range("C3").Select

Dim i As Integer
For i = 2 To Worksheets.Count
Worksheets(i).Select
If WorksheetFunction.CountIf(Cells, "Total") > 0 Then
Cells.Find(What:="Total").Offset(0, 1).Copy
Worksheets("Summary").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Else
Worksheets("Summary").Select
ActiveCell.Offset(1, 0).Select
End If
Next
End Sub
#######################################################

Sub Dynamic_Programming()
Worksheets("Summary").Select
Range("C3:C8").ClearContents
Range("C3").Select

Do While LCase(ActiveCell.Offset(0, -1).Value) <> "total sales"


Worksheets(ActiveCell.Offset(0, -1).Value).Select
If WorksheetFunction.CountIf(Cells, "Total") > 0 Then
Cells.Find(What:="Total").Offset(0, 1).Copy
Worksheets("Summary").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Else
Worksheets("Summary").Select
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub
#########################################################
Sub Dynamic_Programming()
Worksheets("Summary").Select
Range("C3:C8").ClearContents
Range("C3").Select

Do While LCase(ActiveCell.Offset(0, -1).Value) <> "total sales"


If EGCheckSheetisAvailable(ActiveCell.Offset(0, -1).Value) = True Then
Worksheets(ActiveCell.Offset(0, -1).Value).Select
If WorksheetFunction.CountIf(Cells, "Total") > 0 Then
Cells.Find(What:="Total").Offset(0, 1).Copy
Worksheets("Summary").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Else
Worksheets("Summary").Select
ActiveCell.Offset(1, 0).Select
End If
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub

Function EGCheckSheetisAvailable(Sheetname As String) As Boolean


Dim i As Integer

For i = 1 To Worksheets.Count
If LCase(Sheetname) = LCase(Worksheets(i).Name) Then
EGCheckSheetisAvailable = True
Exit Function
End If
Next
EGCheckSheetisAvailable = False
End Function
#############################################################
Sub GenerateSimpleXLReport()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim DataSourceFileName As String


Dim EmployeeName As String
Workbooks.Open Filename:=Range("B3").Value
DataSourceFileName = ActiveWorkbook.Name
ThisWorkbook.Activate
Range("B6").Select
Do While ActiveCell.Value <> ""
EmployeeName = ActiveCell.Value
Workbooks(DataSourceFileName).Activate
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter Field:=3, Criteria1:=EmployeeName
Selection.SpecialCells(Type:=xlCellTypeVisible).Select
Selection.Copy
Workbooks.Add
Range("A1").PasteSpecial
Application.CutCopyMode = False
ActiveSheet.Name = EmployeeName
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & EmployeeName & ".xlsx"
ActiveWorkbook.Close
Workbooks(DataSourceFileName).Activate
Selection.AutoFilter
ThisWorkbook.Activate
ActiveCell.Offset(1, 0).Select
Loop
Workbooks(DataSourceFileName).Close
MsgBox "Macro Complete"

End Sub
#########################################################################
Sub GenerateDetailedXLReport()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim DataSourceFileName As String


Dim EmployeeName As String
Workbooks.Open Filename:=Range("B3").Value
DataSourceFileName = ActiveWorkbook.Name
ThisWorkbook.Activate
Range("B6").Select
Do While ActiveCell.Value <> ""
EmployeeName = ActiveCell.Value
Workbooks(DataSourceFileName).Activate
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter Field:=3, Criteria1:=EmployeeName
Selection.SpecialCells(Type:=xlCellTypeVisible).Select
Selection.Copy
'Workbooks.Add
Workbooks.Open Filename:=ThisWorkbook.Path & "\Template.xlsx"
Worksheets("Data").Select

Range("A1").PasteSpecial
Application.CutCopyMode = False
'ActiveSheet.Name = EmployeeName
Worksheets("Report").Select
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & EmployeeName & "-
Detailed.xlsx"
ActiveWorkbook.Close
Workbooks(DataSourceFileName).Activate
Selection.AutoFilter
ThisWorkbook.Activate
ActiveCell.Offset(1, 0).Select
Loop
Workbooks(DataSourceFileName).Close
MsgBox "Macro Complete"

End Sub
#########################################################################
Sub EGPrepareWorksheetForUse()
Cells.Select
Cells.RowHeight = 20
Cells.VerticalAlignment = xlCenter
Cells.EntireColumn.AutoFit
End Sub
Sub EGAddBorders(InputTopBorder As Boolean, InputRightBorder As Boolean,
InputBottomBorder As Boolean, _
InputLeftBorder As Boolean, InputVerticalBorder As Boolean,
InputHorizontalBorder As Boolean)

If InputLeftBorder = True Then


With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If

If InputTopBorder = True Then


With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If

If InputBottomBorder = True Then


With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If

If InputRightBorder = True Then


With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If

If InputVerticalBorder = True Then


With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If

If InputHorizontalBorder = True Then


With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If
End Sub
####################################################
Sub GenerateSummaryReport()
Worksheets.Add before:=Worksheets(1)
ActiveSheet.Name = "Report"
Worksheets("Data").Select
Range("1:1").Find(What:="Employee Name").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Worksheets("Report").Select
Range("B3").PasteSpecial
Application.CutCopyMode = False
Selection.RemoveDuplicates Columns:=1
ActiveCell.Offset(0, 1).Value = "Total Sales"
ActiveCell.Copy
ActiveCell.Offset(0, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select

Dim EmployeeName As String


Do While ActiveCell.Offset(0, -1).Value <> ""
EmployeeName = ActiveCell.Offset(0, -1).Value
Worksheets("Data").Select

Call EGMakeSimpleSelection("A1")

Selection.AutoFilter Field:=Range("1:1").Find(What:="Employee Name").Column,


Criteria1:=EmployeeName
Selection.SpecialCells(Type:=xlCellTypeVisible).Select
Selection.Copy
Worksheets.Add after:=Worksheets(Worksheets.Count)
Range("A1").PasteSpecial
Application.CutCopyMode = False

Call EGAddBorders(True, True, True, True, True, True)

Call EGPrepareWorksheetForUse

ActiveSheet.Name = EmployeeName
Worksheets("Data").Select
Selection.AutoFilter
Worksheets("Report").Select

ActiveCell.Value = "=SUM(" & EmployeeName & "!H:H)"


ActiveCell.NumberFormat = "#,##0"

ActiveCell.Offset(1, 0).Select
Loop

ActiveCell.Value = "=SUM(C4:" & ActiveCell.Offset(-1, 0).Address & ")"


ActiveCell.Offset(0, -1).Value = "Total Sales"
Range(ActiveCell, ActiveCell.Offset(0, -1)).Font.Bold = True

Call EGPrepareWorksheetForUse
Call EGMakeSimpleSelection("B3")
Call EGAddBorders(True, True, True, True, False, False)

End Sub
###########################################################
Sub EGMakeSimpleSelection(StartRange As String)
Range(StartRange).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
End Sub

You might also like