excelpaidjo: 2016

Friday, January 22, 2016

Saturday, January 16, 2016

How to find item in listbox in VBA

Private Sub CommandButton1_Click()
Dim i As Long
    If TextBox1.Text = "" Then Exit Sub
    For i = 0 To ListBox1.ListCount - 1             ''(1)
        If ListBox1.List(i) = TextBox1.Text Then    ''(2)
            ListBox1.ListIndex = i                  ''(3)
            MsgBox "found in index " & ListBox1.ListIndex
            Exit Sub
        End If
    Next i
    MsgBox "not found"
End Sub

Download File

How to get multi selected item in Listbox VBA

Set Listbox property, MultiSelect : fmMultiSelectMulti

Private Sub CommandButton1_Click()
Dim i As Long, msg As String
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            msg = msg & ListBox1.List(i) & vbCrLf
        End If
    Next i
    MsgBox msg
End Sub

Download File

Thursday, January 14, 2016

Selected Item in Listbox (VBA)

Private Sub CommandButton1_Click()

MsgBox ListBox1.Value

End Sub

Get last item from listbox:

Sub LastItem()
Dim Msg As String

Msg = "Last item:" & vbNewLine

Msg = Msg & ListBox1.List(ListBox1.ListCount - 1) & vbNewLine

MsgBox Msg

End Sub

Select last item of list box:

Sub LastItem()
Dim Msg As String

Msg = "Last item:" & vbNewLine

Msg = Msg & ListBox1.List(ListBox1.ListCount - 1) & vbNewLine

ListBox1.Selected(ListBox1.ListCount - 1) = True

MsgBox Msg

End Sub

Download File

Wednesday, January 13, 2016

How to Add Item to ListBox in VBA (3)

Now, we will add item from Range(A1:A1000000) to listbox

Private Sub CommandButton1_Click()

ListBox1.List = Range("A1:A1000000").Value
MsgBox "Count of items:" & ListBox1.ListCount

End Sub

Now, we will try to chek 'how fast the process is"

Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub CommandButton1_Click()
Dim S As Long

S = GetTickCount
    
ListBox1.List = Range("A1:A1000000").Value
MsgBox "Count of items:" & ListBox1.ListCount & vbCrLf & _
    (GetTickCount - S) / 1000 & "seconds"

End Sub

In my PC, it takes abut 2.203 seconds for 1000000 data.

Download File

Before (1)
Before (2)

How to Add Item to ListBox in VBA (2)

Add item from RowSource

Items want to add

With Listbox properties : RowSource

When we change data in Range("A1:A10"),

Private Sub CommandButton1_Click()

Range("A5") = "DataChange"              'change data

End Sub

and data in listbox also change

Private Sub CommandButton2_Click()

ListBox1.RowSource = "Sheet1!B1:B10"    'change data

End Sub

Download File

Before (1)
Next (3)

How to Add Item to ListBox in VBA (1)

CommandButon1 click:

Private Sub CommandButton1_Click()

ListBox1.AddItem "Sample Data"      'add item to list box

End Sub

Private Sub CommandButton1_Click()
Dim i As Integer

For i = 1 To 10
    ListBox1.AddItem "Sample Data" & i      'add item to list box
Next i

End Sub

Add data from cells

Private Sub CommandButton1_Click()
Dim i As Long

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    ListBox1.AddItem Cells(i, 1)                    'add item to list box
Next i

End Sub

Download File

Next (2)
Next (3)

Password Check and Command Button Enable/Disable

1
2
3

Private Sub CommandButton1_Click()
Call PasswordCheck  ' call sub PasswordCheck when button check click
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then  'enter key
    Call PasswordCheck  'call sub PasswordCheck when Enter key presed
End If
End Sub

Sub PasswordCheck()

With UserForm1
    If .TextBox1.Text = "abc" Then              'if input = abc (corret)
        .CommandButton2.Enabled = True          'enable button 2
        .CommandButton1.Enabled = False         'disable button 1
        .Label1 = "Password correct"            'write to label1
    Else                                        'password is incorrect
        .Label1 = "Password incorrect, please try again" 'write to label
    End If
End With

End Sub

Download File

Saturday, January 9, 2016

General:
1. Macro will create schedule on sheet with index = 1
2. Please do not change name of sheet "Setting"
3. Other sheet will recognize as input ex Sheet Project A , Project B
4. Macro will copy sheet of input from column B tp I

How to setting:
1. In sheet Setting input startDate, FinishDate
2. Input Datestep, <0 is not allowed
3. Choose shape, you can choose Line /rectangle
4. Percentage task progress only can be seen in rectangle shape format
5. Input headerdata for schedule display
6. Input Title

How to create input:
1. Fill any, from column B to I
2. Date start and Date finish are Date format input
3. Progress is percentage format input
4. In sort option, you can choose 0(no sort), 1(ascending), 2/others(descending)

How To Create:
1. Right click On Sheet Schedule, Scheduler > Update
2. if you want to hide finished task, choose Hide 100% Task

Screen Shoot:
Line style

Rectangle style

Download File

Friday, January 8, 2016

Command Button Caption and Execution in VBA

Private Sub CommandButton1_Click()

With CommandButton1
    If .Caption = "Execute" Then                            'if button caption is Execute
        .Caption = "Running"                                'change caption to Running
        For i = 1 To 10000                                  'looping from 1 to 10000
            Cells(i, 1) = i                                 'write i value to cells
            Label1 = "Processed :" & "(" & i & "/10000)"    'update progress to label1
        Next
    End If
    .Caption = "Execute"                                    'after finish chage caption back to Execute

End With

End Sub

But, when we execute, we cant see the progress. So, we need to add DoEvents function to update the process on userform.

Private Sub CommandButton1_Click()

With CommandButton1
    If .Caption = "Execute" Then                            'if button caption is Execute
        .Caption = "Running"                                'change caption to Running
        DoEvents                                            'wait until event finish (Caption become Running)
        For i = 1 To 10000                                  'looping from 1 to 10000
            Cells(i, 1) = i                                 'write i value to cells
            Label1 = "Processed :" & "(" & i & "/10000)"    'update progress to label1
            DoEvents                                        'wait until event finish (write i to cell
                                                            'and process update on label1
        Next
    End If
    .Caption = "Execute"                                    'after finish chage caption back to Execute
End With

End Sub

Now we add Stop option:

Dim FlagStop As Boolean
Private Sub CommandButton1_Click()

With CommandButton1
    If .Caption = "Execute" Then                            'if button caption is Execute
        .Caption = "Stop"                                'change caption to Running
        DoEvents                                            'wait until event finish (Caption become Running)
        FlagStop = False
        For i = 1 To 10000                                  'looping from 1 to 10000
            Cells(i, 1) = i                                 'write i value to cells
            Label1 = "Processed :" & "(" & i & "/10000)"    'update progress to label1
            DoEvents                                        'wait until event finish (write i to cell
                                                            'and process update on label1
            If FlagStop Then Exit For
        Next
    Else
        If MsgBox("Do you want to stop the process?", vbYesNo) = vbYes Then FlagStop = True
    End If
    .Caption = "Execute"                                    'after finish chage caption back to Execute
End With

End Sub

Download File

How to Know SHIFT/CTRL/ALT was pressed in VBA

Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim str As String


Select Case Shift
Case 1
    str = "SHIFT was pressed."
Case 2
    str = "CTRL was pressed."
Case 3
    str = "SHIFT + CTRL was pressed."
Case 4
    str = "ALT was pressed."
Case 5
    str = "ALT + SHIFT was pressed."
Case 6
    str = "ALT + CTRL was pressed."
Case 7
    str = "ALT + SHIFT + CTRL was pressed."
End Select

Me.Label1 = str

End Sub

Download File

Wednesday, January 6, 2016

How to Know Right/Left/Middle Click on Command Button in VBA

a. First add a userform to a Workbook (right click VBE(Visual Basic Editor) > Insert > Userform)
b. Add a command button and a label

c. Right Click Command Button, and then click View Code
d. Then choose, Mouseup event

Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim str As String


Select Case Button
Case 1
    str = "The left button was pressed."
Case 2
    str = "The right button was pressed."
Case 4
    str = "The middle button was pressed."
Case Else
    str = "The unknown button was pressed."
End Select

Me.Label1 = str

End Sub

The settings for Button are:

Download File

How to Get Last Line of a Text File in VBA

Target text file:

Methode1: (loop until last line)

Sub Sample1()
    Dim buf As String
    Const Target As String = "D:\ExcelPaidjo\LastLine\text.txt"
    Open Target For Input As #1
        Do Until EOF(1)
            Line Input #1, buf
        Loop
    Close #1
    MsgBox "Last Line: " & buf
End Sub

Methode2: (Read all line at once, then split become array)

Sub Sample2()
    Dim buf As String, FSO As Object
    Dim LastRow As Long
    Const Target As String = "D:\ExcelPaidjo\LastLine\text.txt"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    With FSO.OpenTextFile(Target, 1)
        buf = .ReadAll
        .Close
    End With
    Set FSO = Nothing
    LastRow = UBound(Split(buf, vbCrLf)) - 1
    MsgBox Split(buf, vbCrLf)(LastRow)
End Sub

Download File

Tuesday, January 5, 2016

How to get Path and File Name from a Full Path

1. With use InStrRev Function

Sub Sample1()
    Dim PathName As String, FileName As String, pos As Long
    pos = InStrRev("D:\ExcelPaidjo\File\FileName\filename.xlsm", "\")
    MsgBox pos
End Sub

Then, to get Path and File Name we use, Left and Mid function.

Sub Sample2()
    Dim PathName As String, FileName As String, pos As Long
    pos = InStrRev("D:\ExcelPaidjo\File\FileName\filename.xlsm", "\")
    PathName = Left("D:\ExcelPaidjo\File\FileName\filename.xlsm", pos)
    FileName = Mid("D:\ExcelPaidjo\File\FileName\filename.xlsm", pos + 1)
    MsgBox PathName & vbCrLf & FileName
End Sub

2. With Use Dir Function

Sub Sample3()
    Dim PathName As String, FileName As String
    FileName = Dir("D:\ExcelPaidjo\File\FileName\filename.xlsm")
    MsgBox FileName
End Sub

then, to get path name we use Replace function.

Sub Sample3()
    Dim PathName As String, FileName As String
    FileName = Dir("D:\ExcelPaidjo\File\FileName\filename.xlsm")
    PathName = Replace("D:\ExcelPaidjo\File\FileName\filename.xlsm", FileName, "")
    MsgBox PathName & vbCrLf & FileName
End Sub

Download File

Monday, January 4, 2016

How to Get Extension File in VBA

Check "xlsx" extension file. Example:

Sub Button1_Click()

Dim Target As String, pos As Long
Target = Application.GetOpenFilename()
pos = InStrRev(Target, ".")
If pos > 0 Then
    If LCase(Mid(Target, pos + 1)) = "xlsx" Then
        ' process for target file
        MsgBox "This xlsx extension file"
    Else
        MsgBox "Not xlsx Extension file", 48
    End If
End If

End Sub

Check "xlsx" or "xls" extension file. Example:

Sub Button2_Click()

Dim Target As String, pos As Long
Target = Application.GetOpenFilename()
pos = InStrRev(Target, ".")
If pos > 0 Then
    If LCase(Mid(Target, pos + 1)) = "xls" Or _
       LCase(Mid(Target, pos + 1)) = "xlsx" Then
        ' process for target file
        MsgBox "This xlsx extension file"
    Else
        MsgBox "Not xlsx Extension file", 48
    End If
End If

End Sub

or , can do with

Sub Button3_Click()

Dim Target As String, pos As Long
Target = Application.GetOpenFilename()
pos = InStrRev(Target, ".")
If pos > 0 Then
    If LCase(Mid(Target, pos + 1)) Like "xls*" Then
        ' process for target file
        MsgBox "This xlsx extension file"
    Else
        MsgBox "Not xlsx Extension file", 48
    End If
End If

End Sub

With use FileSystemObject

Sub Button4_Click()
    Dim Target As String
    Target = Application.GetOpenFilename()
    With CreateObject("Scripting.FileSystemObject")
        If LCase(.GetExtensionName(Target)) = "xls" Or _
           LCase(.GetExtensionName(Target)) = "xlsx" Then
            ' process for target file
            MsgBox "This xlsx extension file"
        Else
            MsgBox "Not xlsx Extension file", 48
        End If
    End With
End Sub

Downloan File

How to Find File in Folder and Subfolders in VBA

To find files in a folder and its subfolder.

1
2
3

Sub Sample()
    Call FileSearch("D:\ExcelPaidjo")
End Sub

Sub FileSearch(Path As String)
    Dim FSO As Object, Folder As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Debug.Print Folder.Path
        Call FileSearch(Folder.Path)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        Debug.Print File.Path
    Next File
End Sub

To find all excel type files.

Sub FileSearch(Path As String)
    Dim FSO As Object, Folder As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Debug.Print Folder.Path
        Call FileSearch(Folder.Path)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        If InStr(File.Type, "Excel") > 0 Then
            Debug.Print File.Path
        End If
    Next File
End Sub

Download File

Sunday, January 3, 2016

How to Browse a Folder in VBA

1. With FileDialog Objet

Sub Sample1()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            MsgBox .SelectedItems(1)
        End If
    End With
End Sub

2. With Shell

Sub Sample2()
    Dim Shell, myPath
    Set Shell = CreateObject("Shell.Application")
    Set myPath = Shell.BrowseForFolder(&O0, "Please select a folder", &H1 + &H10, "C:\")
    If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
    Set Shell = Nothing
    Set myPath = Nothing
End Sub

3. With Use API (methode1)

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
                                        (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
                                        (lpBrowseInfo As BROWSEINFO) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Function GetFolder(Optional Msg) As String
    Dim bInfo As BROWSEINFO, pPath As String
    Dim R As Long, X As Long, pos As Integer
    bInfo.pidlRoot = 0&
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select  folder..."
    Else
        bInfo.lpszTitle = Msg
    End If
    bInfo.ulFlags = &H1
    X = SHBrowseForFolder(bInfo)
    pPath = Space$(512)
    R = SHGetPathFromIDList(ByVal X, ByVal pPath)
    If R Then
        pos = InStr(pPath, Chr$(0))
        GetFolder = Left(pPath, pos - 1)
    Else
        GetFolder = ""
    End If
End Function

Sub Sample3()
    Dim buf As String
    buf = GetFolder("Please select a folder")
    If buf = "" Then Exit Sub
    MsgBox buf
End Sub

4. With Use API (methode2)

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
                                    (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
                                    (lpBrowseInfo As BROWSEINFO) As Long
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                                    (ByVal hWnd As Long, ByVal wMsg As Long, _
                                     ByVal wParam As Long, lParam As Any) As Long

Public Const WM_USER = &H400
Public Const BFFM_SETSELECTIONA = (WM_USER + 102)
Public Const BFFM_INITIALIZED = 1

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As String
    iImage As Long
End Type

Function GetDirectory(Optional Msg, Optional UserPath) As String
    Dim bInfo As BROWSEINFO, pPath As String
    Dim R As Long, X As Long, pos As Integer
    With bInfo
        .pidlRoot = &H0
        If IsMissing(Msg) Then
            .lpszTitle = "Select a folder..."
        Else
            .lpszTitle = Msg
        End If
        .ulFlags = &H40
        .lpfn = FARPROC(AddressOf BrowseCallbackProc)
        If IsMissing(UserPath) Then
            .lParam = CurDir & Chr(0)
        Else
            .lParam = UserPath & Chr(0)
        End If
    End With
    X = SHBrowseForFolder(bInfo)
    pPath = Space$(512)
    R = SHGetPathFromIDList(ByVal X, ByVal pPath)
    CoTaskMemFree X
    If R Then
        pos = InStr(pPath, Chr(0))
        GetDirectory = Left(pPath, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal _
                                lParam As Long, ByVal lpData As Long) As Long
    If uMsg = BFFM_INITIALIZED Then
          SendMessage hWnd, BFFM_SETSELECTIONA, 1, ByVal lpData
    End If
End Function

1
2
3

Public Function FARPROC(pfn As Long) As Long
    FARPROC = pfn
End Function

Sub Sample4()
    Dim buf As String
    buf = GetDirectory("Please select a folder", "C:\")
    If buf = "" Then
        Exit Sub
    Else
        MsgBox buf
    End If
End Sub

Download File
Download File (64bit support)

Subscribe to: Posts ( Atom )

excelpaidjo

Pages

Friday, January 22, 2016

Directory List

Download Index

Saturday, January 16, 2016

How to find item in listbox in VBA

How to get multi selected item in Listbox VBA

Thursday, January 14, 2016

Selected Item in Listbox (VBA)

Wednesday, January 13, 2016

How to Add Item to ListBox in VBA (3)

How to Add Item to ListBox in VBA (2)

How to Add Item to ListBox in VBA (1)

Password Check and Command Button Enable/Disable

Saturday, January 9, 2016

My Project Sceduler

Friday, January 8, 2016

Command Button Caption and Execution in VBA

How to Know SHIFT/CTRL/ALT was pressed in VBA

Wednesday, January 6, 2016

How to Know Right/Left/Middle Click on Command Button in VBA

How to Get Last Line of a Text File in VBA

Tuesday, January 5, 2016

How to get Path and File Name from a Full Path

Monday, January 4, 2016

How to Get Extension File in VBA

How to Find File in Folder and Subfolders in VBA

Sunday, January 3, 2016

How to Browse a Folder in VBA