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 Sub

2.Delete specific shape
Option 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



Thursday, December 5, 2019
Tag :

[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




Access ActiveX Controls by:
Worksheet("sheetname").ComponentName

Ex:
Sub main()
    Debug.Print ActiveSheet.TextBoxName.Value
    'or
    Debug.Print ActiveSheet.OLEObjects("TextBoxName").Object.Value
End Sub

For 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] Excel Form Control

 aaa

[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
2.1 ComandButton



Double click on button, source code of click event will be display as below:
Private Sub CommandButton_CANCEL_Click()
'    Unload Me
    Hide
End Sub

Private Sub CommandButton_OK_Click()
    'some code
    
    Hide
End Sub

2.2 Label
Label1 = "some string"

2.3 InputTextBox
TextBox1.Value = "some string"

2.4 ListBox
'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


2.5 ComboBox
'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


2.6 CheckBox, OptionButton(radio button)
ChekcBox and OptionButton are the same in set/get value
'set init 
CheckBox1.Value = False
        
'some code
'...

'get setting
If CheckBox1.Value = True Then
	'do something 1
Else
	'do something 2
End If


3. Progress dialog
Application.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



2. End xlUp/Down

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 Sub


3.Find text

Sub 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 Sub



4.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 Sub

Result: 
 1             1
 2             2 
 3             2 
 4             3 
 5             3 
 6             3 
 7             4
 8             4
 9             4
 10            4





5. Clear
※https://www.automateexcel.com/vba/clearcontents-clear
Sub 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


6.Cell Font 
6.1 Text
※https://www.automateexcel.com/vba/cell-font-color-size/
'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"

6.2 Background
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



Friday, November 29, 2019
Tag :

[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 = True


3. 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



- Copyright © Lập trình hệ thống nhúng Linux . Powered by Luong Duy Ninh -