Showing posts with label VBA. Show all posts
[VBA] Delete Shapes (Form Controls / ActiveX Controls / Picture)
1.Delete all shapes
Sub Delete_All_Shapes()
'Delete all Objects except Comments
On Error Resume Next
ActiveSheet.DrawingObjects.Visible = True
ActiveSheet.DrawingObjects.Delete
On Error GoTo 0
End Sub2.Delete specific shapeOption Explicit
Private Const TYPE_FORM_CONTROL As Integer = 8 'Forms controls
Private Const TYPE_ACTIVEX_CONTROL As Integer = 12 'ActiveX control (control toolbox) or a linked or embedded OLE object.
Private Const TYPE_PICTURE As Integer = 13 'Picture
Sub Delete_specific_Shapes()
Dim myshape As Shape
For Each myshape In ActiveSheet.Shapes
Debug.Print "-----"
Debug.Print "myshape.Type/Name", myshape.Type, myshape.Name
Debug.Print "", myshape.TopLeftCell.Address, myshape.BottomRightCell.Address
If myshape.Type = TYPE_FORM_CONTROL Then
myshape.Delete
ElseIf myshape.Type = TYPE_ACTIVEX_CONTROL Then
' myshape.Delete
ElseIf myshape.Type = TYPE_PICTURE Then
' myshape.Delete
End If
' You can also use myshape.Visible = False
Next myshape
End Sub
[VBA] Insert ComboBox reference to list using name alias
1. Create new name alias
- Ctrl + F3 to open Name Manager
- Click "New"
- Input "Name" and select "Refers to"
- Click OK, close Name Manager
2. Insert ComboBox
- Click on cell where will be insert ComboBox
- From menu bar, select "Data / Data Validation"
- In "Settings" tab, select "List" to "Allow" field
- In "Source" field, input below content
="defined name alias in step1"
[VBA] Insert Picture
Option Explicit
Sub main()
Dim imagepath As String
Dim imagePos As Range
imagepath = "C:\Users\mypc\Pictures\myimg\commandbutton.JPG"
Set imagePos = Range("B2:D8")
Call InsertPictureInRange(imagepath, imagePos)
End Sub
' inserts a picture and resizes it to fit the TargetCells range
Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub
[VBA] ActiveX Controls
1. Create and set/get value to control
Sub main()
Debug.Print ActiveSheet.TextBoxName.Value
'or
Debug.Print ActiveSheet.OLEObjects("TextBoxName").Object.Value
End SubFor how to set/get component value, reference to UserForm
2. Get type of ActiveX control
Sub getTypeControl()
Dim ws As Worksheet
Dim oleob As OLEObject
Set ws = ActiveSheet
For Each oleob In ws.OLEObjects
If TypeName(oleob.Object) = "TextBox" Then 'if type: TextBox
oleob.Object.Value = "hihi haha"
End If
Next
End Sub[VBA] UserForm
https://www.excel-easy.com/vba/userform.html
1. Begin / End
・UserForm1.Show
Display userform
・UserForm1.Hide
Do not display userform, form's data are remain
・Unload UserForm1
Destroy userform (userform do not display and all form'data also not exist)
Option Explicit
Sub main()
With UserForm1
'Display form dialog
.Show
'Some code
Debug.Print "Some code"
End With
'Destroy form
Unload UserForm1
End Sub
2.UserForm component
Private Sub CommandButton_CANCEL_Click()
' Unload Me
Hide
End Sub
Private Sub CommandButton_OK_Click()
'some code
Hide
End Sub
'Empty ListBox1
ListBox1.Clear
'Fill ListBox1
With ListBox1
.AddItem "San Francisco"
.AddItem "Oakland"
.AddItem "Richmond"
End With
'get ListBox1
Cells(emptyRow, 3).Value = ListBox1.Value'Empty ComboBox1
ComboBox1.Clear
'Fill ComboBox1
With ComboBox1
.AddItem "San Francisco"
.AddItem "Oakland"
.AddItem "Richmond"
End With
'set defaul item to 1st item (San Francisco)
Combobox1.ListIndex=0
'get ComboBox1 by value
Cells(emptyRow, 3).Value = ComboBox1.Value 'San Francisco because ListIndex=0
'get ComboBox1 by Index
Cells(emptyRow, 3).Value = ComboBox1.List(1) 'Oakland'set init
CheckBox1.Value = False
'some code
'...
'get setting
If CheckBox1.Value = True Then
'do something 1
Else
'do something 2
End IfApplication.ScreenUpdating = True
progressCounter = progressCounter + 1
UserForm1.Label_progress.Caption = "test msg"
UserForm1.Label_filename.Caption = "test msg"
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents
Application.ScreenUpdating = False[VBA] On Error
VBA Runtime Errors:
・Referencing a non-existent workbook, worksheet, or other object
・Invalid data ex. referencing an Excel cell containing an error
・Attempting to divide by zero
VBA On Error Statement:
・On Error GoTo 0
IF error, program is stop, display default error dialog
・On Error Resume Next
IF error, do not display error dialog, continue run next line code
・On Error GoTo Label
IF error, goto user defined label
Option Explicit
Sub ErrorResumenext()
'IF error, do not display error dialog, continue run next line code
'It mean that [Some code] will be run continue although error occur
On Error Resume Next
ActiveSheet.Shapes("Start_Button").Delete
If Err.Number <> 0 Then
Debug.Print "Error"
Else
Debug.Print "No error"
End If
'Some code
Debug.Print "do something"
End Sub
Sub ErrorGoTo0()
On Error Resume Next
ActiveSheet.Shapes("Start_Button").Delete
'From here IF error, program is stop, display default error dialog
'It mean that [Some code] do not run if error occur
On Error GoTo 0
ActiveSheet.Shapes("Start_Button").Delete
'Some code
Debug.Print "do something"
End Sub
Sub ErrGoToEnd()
'IF error, goto label nextProc
On Error GoTo nextProc
ActiveSheet.Shapes("Start_Button").Delete
'Some Code 1
nextProc:
'Some Code 2
End Sub
[VBA] Access Window Registry
Attribute VB_Name = "registry"
Sub readRegistry()
Dim regkey As String
regkey = "HKEY_LOCAL_MACHINE\SOFTWARE\7-Zip\Path"
Debug.Print RegKeyRead(regkey)
End Sub
'reads the value for the registry key i_RegKey
'if the key cannot be found, the return value is ""
Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object
On Error Resume Next
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'read key from registry
RegKeyRead = myWS.RegRead(i_RegKey)
End Function
'returns True if the registry key i_RegKey was found
'and False if not
Function RegKeyExists(i_RegKey As String) As Boolean
Dim myWS As Object
On Error GoTo ErrorHandler
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'try to read the registry key
myWS.RegRead i_RegKey
'key was found
RegKeyExists = True
Exit Function
ErrorHandler:
'key was not found
RegKeyExists = False
End Function
'sets the registry key i_RegKey to the
'value i_Value with type i_Type
'if i_Type is omitted, the value will be saved as string
'if i_RegKey wasn't found, a new registry key will be created
Sub RegKeySave(i_RegKey As String, _
i_Value As String, _
Optional i_Type As String = "REG_SZ")
Dim myWS As Object
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'write registry key
myWS.RegWrite i_RegKey, i_Value, i_Type
End Sub
'deletes i_RegKey from the registry
'returns True if the deletion was successful,
'and False if not (the key couldn't be found)
Function RegKeyDelete(i_RegKey As String) As Boolean
Dim myWS As Object
On Error GoTo ErrorHandler
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'delete registry key
myWS.RegDelete i_RegKey
'deletion was successful
RegKeyDelete = True
Exit Function
ErrorHandler:
'deletion wasn't successful
RegKeyDelete = False
End Function
[VBA] Access SQL database
Attribute VB_Name = "sqldatabase"
Option Explicit
'----------------------------------------------------------------------------
'Tool > References and check on Microsoft AciveX Data Object 2.5 Library
'----------------------------------------------------------------------------
Sub GetDataFromADO()
'database info
Dim src As String
Dim user_id As String
Dim password As String
Dim dbname As String 'database name
Dim tbname As String 'table name
src = "localhost\SQLEXPRESS"
user_id = "sa"
password = "123456"
dbname = "dd"
tbname = "[dd].[dbo].[numbertalbe]"
'Declare variables'
' Dim objMyRecordset As Object
Dim objMyConn As ADODB.Connection 'ADO Connection Object
Dim objMyRecordset As ADODB.Recordset 'ADO Recordset Object
Set objMyConn = New ADODB.Connection
Set objMyRecordset = New ADODB.Recordset
Dim strSQL As String
'Open Connection'
objMyConn.ConnectionString = "Provider=SQLOLEDB;Data Source=" & src & ";Initial Catalog=" & dbname & ";User ID=" & user_id & ";Password=" & password & ";"
objMyConn.Open
'Set and Excecute SQL Command'
strSQL = "select * from " & tbname
strSQL = "SELECT * FROM " & tbname
'Open Recordset'
Set objMyRecordset.ActiveConnection = objMyConn
objMyRecordset.Open strSQL
'Copy Data to Excel'
'ActiveSheet.Range("A1").CopyFromRecordset (objMyRecordset)
'Get data
Dim i As Integer
Dim recordsre As String
Debug.Print "--------"
recordsre = ""
For i = 0 To objMyRecordset.Fields.Count - 1
recordsre = recordsre & CStr(objMyRecordset.Fields(i).Name) & " " 'get collumn
Next i
Debug.Print recordsre
objMyRecordset.MoveFirst
Do Until objMyRecordset.EOF
recordsre = ""
For i = 0 To objMyRecordset.Fields.Count - 1
recordsre = recordsre & CStr(objMyRecordset.Fields(i).Value) & " " 'get value
Next i
Debug.Print recordsre
objMyRecordset.MoveNext
Loop
objMyRecordset.Close
objMyConn.Close
Set objMyRecordset = Nothing
Set objMyConn = Nothing
End Sub
[VBA] WorkSheet_Cell_Range
1.Basic (select)
・Rows
Rows(123) 'row 123 only
Rows("2:5") 'range of rows from row 2 to 5
・Columns
Columns(123) / Columns("B") '1 comlumn only
Columns("B:D") 'range of columns form column B to D
・Cells
Cells(2, 4) / Cells(2, "D")
・Range
Range("A2") 'Cell A2 only
Range("A2:B10") 'Cell from A2 to B10
Range("A:A") 'Column A
Range("A:D") 'Column A to column D
Range("2:2") 'Row 2
Range("2:4") 'Row 2 to row 4
Option Explicit
Private Const NAME_COL As String = "B"
Private Const AGE_COL As String = "C"
Private Const START_ROW As Integer = 2
Sub range_select()
Dim sColum As Range, sRow As Range
Set sColum = Columns("B")
Set sRow = Rows(2)
End Sub
Sub cell_scan_column()
Dim i As Integer
With ThisWorkbook.Worksheets("cell_scan")
For i = START_ROW To 10
If .Cells(i, NAME_COL).Value <> "" Then
'by Cells
Debug.Print .Cells(i, NAME_COL).Value, .Cells(i, AGE_COL).Value
'or by Range
Debug.Print .Range(NAME_COL & i).Value, .Range(AGE_COL & i).Value
Else
Exit For
End If
Next
End With
End Sub
Sub worksheet_EndxlDown()
' Neu Cells(startRow, "B") co data thi End(xlDown) se tra ve cell cuoi cung co data (cell tiep theo se la mot empty cell)
' maxrow > startRow
'
' Neu Cells(startRow, "B") la empty cell thi End(xlDown) se tra ve cell dau tien co data tinh startRow
' maxrow > startRow
'
'NOTE:
' - vi tri cell tra ve cung tren column "B" (duyet theo column B)
Dim startRow As Long, maxrow As Long
startRow = 1
maxrow = Cells(startRow, "B").End(xlDown).Row
Debug.Print maxrow
End Sub
Sub worksheet_EndxlUp()
' nguyen tac giong voi xlDown, chi khac la chieu tu duoi len tren
' maxrow < startRow
Dim startRow As Long, LastRow As Long
startRow = 65000
' startRow = ActiveSheet.Rows.Count 'dung de xac dinh cell cuoi cung co data tren B column
LastRow = Cells(startRow, "B").End(xlUp).Row
Debug.Print maxrow
End SubSub worksheet_findText()
'Note: other option
' LookIn:=xlValues -> looks at the cell values
' LookAt:=xlWhole -> full match or xlPart means the search value only has to match part of the cell
' SearchDirection:=xlNext or xlPrevious
' After:=Range("A2") -> tim kiem tu vi tri cell tiep theo A3
Dim cell As Range
Dim Addr As String
'---------------------------------------------------------------------
' tim kiem trong khoang A1:B6, tu vi tri cell A3 (After:=Range("A2") )
' NOTE: After cell phai trong pham vi Range("A1:B6")
Set cell = Range("A1:B6").Find("Drucilla", After:=Range("A2"))
If cell Is Nothing Then
Debug.Print "Not found"
Else
Addr = cell.Address
Debug.Print "Addr: " & Addr
End If
'---------------------------------------------------------------------
' tim kiem o column A, tu vi tri cell A3 (After:=Range("A2") )
Set cell = Columns("A").Find("Drucilla", After:=Range("A2"))
If cell Is Nothing Then
Debug.Print "Not found"
Else
Addr = cell.Address
Debug.Print "Addr: " & Addr
End If
'---------------------------------------------------------------------
' tim kiem tren toan bo cells
Set cell = Cells.Find("Drucilla", After:=Range("A2"))
If cell Is Nothing Then
Debug.Print "Not found"
Else
Addr = cell.Address
Debug.Print "Addr: " & Addr
End If
End Sub4.MergeCells
Sub merge_test()
Dim i As Long, k As Long
Dim tmpStr As String
Dim edgeTop As Long, edgeBottom As Long
For i = 1 To 10
If Cells(i, "B").MergeCells Then
Debug.Print i, Range("B" & Range(Cells(i, "B").MergeArea.Address).Row).Value
Else
'find edgeTop and edgeBottom
edgeTop = i
While Cells(edgeTop, "B").Borders(xlEdgeTop).LineStyle = xlNone
edgeTop = edgeTop - 1
Wend
edgeBottom = i
While Cells(edgeBottom, "B").Borders(xlEdgeBottom).LineStyle = xlNone
edgeBottom = edgeBottom + 1
Wend
tmpStr = ""
For k = edgeTop To edgeBottom
If Trim(Cells(k, "B").Value) <> "" Then
tmpStr = tmpStr & " " & Cells(k, "B").Value
End If
Next
Debug.Print i, tmpStr
End If
Next
End SubResult:
1 1
2 2
3 2
4 3
5 3
6 3
7 4
8 4
9 4
10 4Sub clear_test()
Range("a1").Clear 'Everything
Range("a1").ClearComments 'Comments
Range("a1").ClearContents 'Contents
Range("a1").ClearFormats 'Formats
Range("a1").ClearHyperlinks 'Hyperlinks
Range("a1").ClearNotes 'Notes
Range("a1").ClearOutline 'Outline
End Sub'vbBlack, vbBlue, vbCyan, vbGreen, vbMagenta, vbRed, vbWhite, vbYellow
Range("a1").Font.Color = vbRed
Range("a1").Font.Color = RGB(255,255,0)
Range("a1").Font.Size = 12
Range("A1").Font.Bold = True
Range("A1").Font.Name = "Arial"
Sub checkBackgroundColor_test()
Dim i As Integer
For i = 1 To 10
If Cells(i, "A").Interior.Color <> vbWhite Then
Debug.Print "row:", i, Cells(i, "A").Interior.Color
End If
Next
End Sub[VBA] WScript_Shell
1.Basic
- Run: wait to command finish and return exit code only
- Exec: get output stream of command
Option Explicit
Sub test_compare_getReturnCode()
Dim cmd As String
cmd = "fc /lb2 /b C:\Users\NinhLD\Downloads\vba\cmp\as.exe C:\Users\NinhLD\Downloads\vba\cmp\ash.exe > NUL"
Dim ret As Integer
ret = ShellRunGetReturnCode(cmd)
Select Case ret
Case 0
Debug.Print "two File are the same"
Case Else
Debug.Print "two File are not the same"
End Select
End Sub
Sub test_compare_getOutput()
Dim cmd As String
cmd = "fc /b C:\Users\NinhLD\Downloads\vba\cmp\excel_VBA.txt C:\Users\NinhLD\Downloads\vba\cmp\excel_VBA2.txt"
Debug.Print ShellRunGetOutput(cmd)
End Sub
'---API start---
Public Function ShellRunGetReturnCode(ByVal sCmd As String) As Integer
ShellRunGetReturnCode = -1
sCmd = "cmd /c " & sCmd
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
ShellRunGetReturnCode = oShell.Run(sCmd, 0, True) 'set 0 to hiden window, 1 to show window
End Function
Public Function ShellRunGetOutput(sCmd As String) As String
'Run a shell command, returning the output as a string
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
'run command
Dim oExec As Object
Dim oOutput As Object
Set oExec = oShell.Exec(sCmd)
Set oOutput = oExec.StdOut
'handle the results as they are written to and read from the StdOut object
Dim s As String
Dim sLine As String
While Not oOutput.AtEndOfStream
sLine = oOutput.ReadLine
If sLine <> "" Then s = s & sLine & vbCrLf
Wend
ShellRunGetOutput = s
End Function
[VBA] WorkSheet_produce
1. Add new sheet
Dim ws As Worksheet
Set ws = Sheets.add
ws.Name = "NewSheet1"
'or
Sheets.add
ActiveSheet.Name = "NewSheet2"
'or
Sheets.add.Name = "NewSheet3"
'or add to 1st
Sheets.add(Before:=Sheets(1)).Name = "FirstSheet"
'or add to last
Sheets.add(After:=Sheets(Sheets.Count)).Name = "LastSheet"
'or add to after
Sheets.add(After:=Sheets("Sheet1")).Name = "NewSheet4"
'or add to before
Sheets.add(Before:=Sheets("Sheet1")).Name = "NewSheet5"2. Delete sheet
Application.DisplayAlerts = False
Worksheets("Sheet3").Delete
Application.DisplayAlerts = True3. Move sheet
Worksheets("Sheet3").Move after:=Worksheets("Sheet1")
Worksheets("Sheet3").Move before:=Worksheets("Sheet1")4. Copy sheet
Option Explicit
'Struct: workbook.worksheet.Cell/Range
'Select worksheet: by name Worksheets("worksheetName") or by index Worksheets(1), Worksheets(2)
'Select current worksheet: ActiveSheet
'Select or active sheet
Sub worksheet_produce()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'---Select sheet---
With Worksheets("Sheet1")
'EDIT worksheet "Sheet1"
.Cells(1, 1).Value = "here is sheet 1"
End With
With ActiveSheet
'EDIT current sheet
.Cells(1, 1).Value = "here is current sheet"
End With
'---Active sheet---
Worksheets("Sheet2").Activate
End Sub
Sub worksheet_listAll()
'---list all sheet---
Dim i As Integer
For i = 1 To ThisWorkbook.Sheets.Count
Debug.Print "By index: " & ThisWorkbook.Sheets(i).Name
Next i
Dim Item As Worksheet
For Each Item In ThisWorkbook.Worksheets
Debug.Print "by worksheet item: " & Item.Name
Next
End Sub
Sub worksheet_Copy()
'copy to new workbook
Debug.Print ActiveWorkbook.Name 'output: vba.xlsx
Worksheets(Array("Sheet1", "Sheet2")).Copy
Debug.Print ActiveWorkbook.Name 'output: Book1
Worksheets("Sheet1").Copy After:=Worksheets("Sheet2") 'copy Sheet1 to after Sheet2 in Book1
'NOTE: After copy ActiveWorkbook change to new Book1
End Sub
[VBA] WorkBook_produce
Option Explicit
'Struct: workbook.worksheet.Cell/Range
'Select workbook: Workbooks("workbookName")
'NOTE:
' ThisWorkbook: this vba source code owner workbook
' ActiveWorkbook: in case mutiple workbook are opened, ActiveWorkbook which is selected(focus)
' Worksheet RUN ON ActiveWorkbook
' -> ActiveWorkbook.ActiveSheet.Cell/Range
' -> BE CAREFUL WHEN OPENED MULTIPLE WORKBOOK AT THE SAME TIME
'Select worksheet: by name Worksheets("worksheetName") or by index Worksheets(1), Worksheets(2)
'Select current worksheet: ActiveSheet
'Create new blank workbook
Sub workbook_add()
Dim NewBook As Workbook
Set NewBook = Workbooks.add
Debug.Print "NewBook name: " & NewBook.Name
End Sub
Sub Workbook_open_save()
Dim filepath As String, filename As String
filename = "mywb.xlsx"
filepath = "C:\Users\NinhLD\Downloads\vba\workbook\" & filename
'OPEN WORKBOOK
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Open(filepath)
Debug.Print "ThisWorkbook.Name: " & ThisWorkbook.Name
Debug.Print "targetWorkbook.Name: " & targetWorkbook.Name
'OPENED WORKBOOK INSTANCE
With targetWorkbook
'EDIT WORKBOOK
.Worksheets("Sheet1").Cells(1, 1).Value = "test text"
Application.DisplayAlerts = False
.SaveAs filename:=ThisWorkbook.path & "\copbook.xlsx" 'save mywb.xlsx as other copbook.xlsx
.Close SaveChanges:=True 'and CLOSE(SAVE change) mywb.xlsx
Application.DisplayAlerts = True
End With
'NOTE close without saving
'Workbooks("BOOK1.XLS").Close SaveChanges:=False
End Sub
Sub workbook_active()
Workbooks("book.xlsx").Activate
ThisWorkbook.Activate
End Sub
Sub workbook_listall()
Debug.Print "Number of opened workbook: " & Workbooks.Count
Dim Item As Workbook
For Each Item In Workbooks
Debug.Print "Workbook item: " & Item.Name
Next
End Sub
[VBA] With_produce
Option Explicit
'with use to set atribute or run method of instance
'
'
Sub with_produce()
' child with
With Worksheets("Sheet1")
With .Range("A1") ' Sheet1.Range("A1")
.Value = "Tips" ' Sheet1.Range("A1").Value
.Font.Color = RGB(255, 0, 0) ' Sheet1.Range("A1").Font.Color
End With
End With
' or
With Worksheets("Sheet1").Range("A1")
.Value = "Tips" ' Sheet1.Range("A1").Value
.Font.Color = RGB(255, 0, 0)
.Interior.Color = RGB(255, 255, 0)
End With
'open workbook -> edit -> close(save)
With Workbooks.Open(ThisWorkbook.path & "\data\test.xlsx")
With .Worksheets(1)
'edit sheet1 here
End With
.Close
End With
End Sub
[VBA] Sub_function
Option Explicit
'Note: can use "Exit Sub" or "Exit Function" to terminate process
Sub Main()
Dim a As Integer, b As Integer, ret As Integer
a = 1
b = 2
'call function with reference variable
Call add(a, b, ret)
Debug.Print "add sum = " & ret
'call function by value
ret = add2(a, b)
Debug.Print "add2 sum = " & ret
'call sub produce, reference variable
Call minus(a, b, ret)
Debug.Print "minus : " & ret
End Sub
'sub produce, reference variable
Sub minus(a As Integer, b As Integer, sum As Integer)
sum = a - b
End Sub
'function with reference variable
Function add(a As Integer, b As Integer, sum As Integer) As Boolean
sum = a + b
add = True
End Function
'function by value
Function add2(ByVal a As Integer, ByVal b As Integer) As Integer
add2 = a + b
End Function
[VBA] Loop_process
Option Explicit
'Note: Can use "Exit Do, Exit For to exit For loop and Do loop
Sub ForEach_loop()
'fruits is an array
Dim fruits() As Variant
Dim Item As Variant
ReDim Preserve fruits(3)
fruits = Array("apple", "orange", "cherries")
'iterating using For each loop.
For Each Item In fruits
Debug.Print Item
' Exit For
Next
End Sub
Private Sub For_loop()
Dim a As Integer, i As Integer
a = 10
For i = 0 To a Step 2
Debug.Print "The value is i is : " & i
' Exit For
Next
End Sub
Private Sub While_loop()
Dim Counter As Integer
Counter = 10
While Counter < 15 ' Test value of Counter.
Counter = Counter + 1 ' Increment Counter.
Debug.Print "The Current Value of the Counter is : " & Counter
Wend ' While loop exits if Counter Value becomes 15.
End Sub
Private Sub DoWhile_loop()
Dim i As Integer
Do While i < 5
i = i + 1
Debug.Print "The value of i is : " & i
'Exit Do
Loop
End Sub
Private Sub DoUntil_loop()
Dim i As Integer
i = 10
Do Until i > 15 'Condition is False.Hence loop will be executed
i = i + 1
Debug.Print ("The value of i is : " & i)
'Exit Do
Loop
End Sub

