Archive for the ‘Function’ Category
  • Filed under: Excel VBA 範例, Function 統計字串中共有多少個字句及字元 by chijanzen on 九月 29th, 2008
    統計字串中共有多少個字句

    Function 聲明

    Function Number_of_Words(Text_String As String) As Integer

    說明
    統計字串中共有多少個字句     返回值 Integer 參數表 參數 類型及說明

    Text_String

    String 資料型態。可以是指定的儲存格或字串

    程式碼
    Function Number_of_Words(Text_String As String) As Integer
    '統計字串中有幾個字句
      vWords = Split(Text_String, " ")
      Number_of_Words = UBound(vWords) + 1 - LBound(vWords)
    End Function
     

    範例:

     


    Sub test()
        MsgBox "儲存格 I4 共有 " & Number_of_Words(Range("I4")) & " 字句"
    End Sub

     

    檔案下載:檔案下載


    Popularity: 8%

    Read More » Tags
    • No Tags
     Share Comments (0)
  • Filed under: Excel VBA 範例, Function 判斷儲存格內是否含註解 by chijanzen on 七月 20th, 2008
    判斷儲存格內是否含註解

    Function 聲明

    Function CommentExists(rIn As Range) As Boolean
    說明

    判斷儲存格內是否含註解
    返回值

    Boolean
    參數表
    參數 類型及說明

    rng

    Range；Range
    物件，該物件代表一個儲存格或儲存格範圍
    程式碼

    Function CommentExists(rng As Range) As Boolean
        Dim rComment As Comment
        Set rComment = rng.Comment
        If xComment Is Nothing Then
            CommentExists = False
        Else
            CommentExists = True
        End If
    End Function

    範例:判斷 A1 儲存格是否含註解

    　


    Sub test()
        MsgBox "儲存格 A1" & IIf(CommentExists(Range("A1")), "含", "不含" & "註解")
    End Sub

    Popularity: 8%

    Read More » Tags
    • No Tags
     Share Comments (0)
  • Filed under: Excel VBA 範例, Function 取得預設瀏覽器(default web browser)的名稱 by chijanzen on 六月 20th, 2008
    索   引

       K0014
    主   題

       取得預設瀏覽器(default web
    browser)的名稱
    版   本

       >=
    10.0(Office 2002)
    說   明

       當我在寫
    Excel VBE Google Search 增益集 時，因為使用    DHTM
    控件，所以預設的網頁瀏覽器需為 IE ，否則無法開啟搜尋網頁。    當時一直找不到方法來取得取得預設瀏覽器(default
    web browser)的名稱，今天無意間發現只要取得註冊表中的 HKEY_CLASSES_ROOT\HTTP\shell\open\ddeexec\Application
    值，就能取得預設瀏覽器的名稱，於是寫了一個 GetDefaultBrowser Function 將這次的發現記錄下來

    參   考

      


    複製以下程式碼到Module

    Code


    Function GetDefaultBrowser()
        Dim objShell
        Set objShell = CreateObject("WScript.Shell")
        'HKEY_CLASSES_ROOT\HTTP\shell\open\ddeexec\Application
        '取得註冊表中的值
        GetDefaultBrowser = objShell.RegRead _
                ("HKCR\http\shell\open\ddeexec\Application\")
    End Function
    　



    Sub Run()
        MsgBox "預設的瀏覽器為 :" & GetDefaultBrowser
    End Sub
    　    　

    Help

    Code

     
    Script 能使用的根鍵值有五個。

    根鍵名稱
    HKEY_CURRENT_USER       '縮寫 HKCU
    HKEY_LOCAL_MACHINE      '縮寫 HKLM
    HKEY_CLASSES_ROOT       '縮寫 HKCR
    HKEY_USERS                  
    '縮寫 HKEY_USERS
    HKEY_CURRENT_CONFIG    '縮寫 HKEY_CURRENT_CONFIG



     
    取得    預設瀏覽器(default web
    browser)應用程式的路徑，程式碼如下:



    Private Declare Function     FindExecutable Lib "shell32.dll" Alias _
            "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As _
            String, ByVal lpResult As String) As Long

    Function GetDefaultBrowserPath()
        Dim FileName As String, Dummy As String
        Dim BrowserExec As String * 255
        Dim RetVal As Long
        Dim FileNumber As Integer
        BrowserExec = Space(255)
        FileName = "C:\temphtm.HTM"
        FileNumber = FreeFile
        Open FileName For Output As #FileNumber
        Write #FileNumber, "<HTML> <\HTML>"
        Close #FileNumber
        '取得開啟 *.HTM檔案預設的應用程式
        RetVal = FindExecutable(FileName, Dummy, BrowserExec)
        GetDefaultBrowserPath = Trim(BrowserExec)
    End Function
    　

    DownLoad

    Code

             

     
    檔案下載

    Popularity: 9%

    Read More » Tags
    • No Tags
     Share Comments (0)
  • Filed under: Excel VBA 範例, Function 轉換Excel欄數成字母符號(如第27欄轉換為 I 字母) by chijanzen on 六月 20th, 2008


    轉換Excel欄數成字母符號(如第27欄轉換為 I 字母)

    Function 聲明

    Function ConvertToLetter(iCol As Integer) As String
    說明

    轉換Excel欄數成字母符號(如第27欄轉換為 I 字母)
    返回值

    String
    參數表
    參數 類型及說明

    iCol

    Integer；Integer
    資料型態，代表一個欄數
    程式碼

    Function ConvertToLetter(iCol As Integer) As String
        Dim iAlpha As Integer
        Dim iRemainder As Integer
        iAlpha = Int(iCol / 27)
        iRemainder = iCol - (iAlpha * 26)
        If iAlpha > 0 Then
            '字元碼 65 為英文字母大寫 A
            ConvertToLetter = Chr(iAlpha + 64)
        End If
        '兩位數的欄名
        If iRemainder > 0 Then
            ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
        End If
    End Function

    範例:將目前的儲存格所在的欄數轉換為英文字母

    　


    Sub     test()
        MsgBox "目前的儲存格位於 " & _
               ConvertToLetter(ActiveCell.Column) & " 欄"
    End Sub
    　





    Function ConvertToLetter(iCol As Integer) As String
        Dim iAlpha As Integer
        Dim iRemainder As Integer
        iAlpha = Int(iCol / 27)
        iRemainder = iCol - (iAlpha * 26)
        If iAlpha > 0 Then
            '字元碼 65 為英文字母大寫 A
            ConvertToLetter = Chr(iAlpha + 64)
        End If
        '兩位數的欄名
        If iRemainder > 0 Then
            ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
        End If
    End Function

    Popularity: 11%

    Read More » Tags
    • No Tags
     Share Comments (0)
  • Filed under: Excel VBA 範例, Function 判斷否個增益集(*.xla 或*.xll")是否已安裝且啟用 by chijanzen on 六月 20th, 2008

    判斷否個增益集(*.xla 或*.xll")是否已安裝且啟用

    Function 聲明

    Function IsAddinAvailable(ByVal strAddinFile As String) As Boolean
    說明

    判斷某個增益集(*.xla或*.xll")是否已安裝且啟用
    返回值

    Boolean
    參數表
    參數 類型及說明

    IsAddinAvailable

    String；
    字串    ，增益集檔案名稱(例如:SUMIF.XLA)
    程式碼

    Function IsAddinAvailable(ByVal strAddinFile As String) As Boolean
        Dim iLoop As Long
        With Application
        '取得增益集的項目
            For iLoop = 1 To .AddIns.Count Step 1
            '增益集檔名相同時表示已安裝增益集，接著檢查是否已啟用
                If Dir(.AddIns(iLoop).FullName) = strAddinFile Then
                '檢查是否啟用
                    If .AddIns(iLoop).Installed = True Then
                        IsAddinAvailable = True
                        Exit Function
                    End If
                End If
            Next iLoop
            IsAddinAvailable = False
        End With
    End Function
    　

    範例:

    　

    請先下載範例:常駐於工具列上的月曆控件-增益集(第二版)

    解壓縮後先執行 InstallAddin.xls 中的 Install 按鈕來安裝
    Calendar.xla 增益集

    等測試完後，你可以再按 UnInstall 按鈕來移除此增益集

    　


    Sub     test()
        Const sAddIn = "Calendar.xla"
        On Error Resume Next
        bln = AddIns(sAddIn).Installed
        If IsAddinAvailable(sAddIn) Then
            '你的程式碼
            MsgBox "已安裝增益集" & sAddIn
        Else
            MsgBox "未安裝增益集" & sAddIn
            Exit Sub
        End If
    End Sub
    　


    Function IsAddinAvailable(ByVal strAddinFile As String) As Boolean
        Dim iLoop As Long
        With Application
        '取得增益集的項目
            For iLoop = 1 To .AddIns.Count Step 1
            '增益集檔名相同時表示已安裝增益集，接著檢查是否已啟用
                If Dir(.AddIns(iLoop).FullName) = strAddinFile Then
                '檢查是否啟用
                    If .AddIns(iLoop).Installed = True Then
                        IsAddinAvailable = True
                        Exit Function
                    End If
                End If
            Next iLoop
            IsAddinAvailable = False
        End With
    End Function

    　

    Popularity: 9%

    Read More » Tags
    • No Tags
     Share Comments (0)
  • Filed under: Excel VBA 範例, Function 取得字串中的數值(移除所有的文字) by chijanzen on 六月 20th, 2008
    取得字串中的數值(移除所有的文字)

    Function 聲明


    Function     GetNumbers(TargetText As Variant) As String
    說明
    本函
    數將只取字串中 0-9 數值，而移除所有的文字
    返回值

    String
    參數表
    參數 類型及說明

    TargetText

    Variant
    程式碼

    Function GetNumbers(TargetText As Variant) As String
    '取得字串中的數值(移除所有的文字)
        Dim LenStr As Long
        For LenStr = 1 To Len(TargetText)
            Select Case Asc(Mid(TargetText, LenStr, 1))
            '數字 0-9
            Case 48 To 57
                GetNumbers = GetNumbers & Mid(TargetText, LenStr, 1)
            End Select
        Next
    End Function
    　

    範例:

    　


    Sub     test()
      Const txt = "a123b4cde5fg678hi9j0"
      MsgBox GetNumbers(txt)
    End Sub

    　

    或是運用在儲存格上

    　

    =GetNumbers(A1)

    　

    　


    說明:本函數是以字串的方式傳回值，若是要以為數值傳回值則應更改如下:

    　


    Function     GetNumbers(TargetText As Variant) As Double

        '取得字串中的數值(移除所有的文字)
        Dim LenStr As Long
        For LenStr = 1 To Len(TargetText)
            Select Case Asc(Mid(TargetText, LenStr, 1))
                '數字 0-9
                GetNumbers = GetNumbers & Mid(TargetText, LenStr, 1)
            End Select
        Next
        GetNumbers = CDbl(GetNumbers)
    End Function

            Case 48 To 57

    chijanzen 2005/11/06

    Popularity: 9%

    Read More » Tags
    • No Tags
     Share Comments (0)
Page 1 of 3123
Blue Green Grey Orange Purple Red
About me
chijanzen 分享個人Excel VBA 學習經驗,架站心得, 日常生活記事等...

Add to Google

分類
Translator
Chinese (Simplified) flagItalian flagKorean flagEnglish flagGerman flag
French flagJapanese flagRussian flagBulgarian flagFinnish flag
線上人數

相簿
Copyright © 2009 chijanzen 雜貨舖.
All rights reserved.
Proudly powered by WordPress
View more Premium WordPress Themes