Private Sub CommandButton1_Click()
    r = Range("A65536").End(xlUp).Row + 1
    Cells(r, "A") = 日期.Text
    Cells(r, "B") = 品號.List(品號.ListIndex, 0)
    Cells(r, "C") = 品號.List(品號.ListIndex, 1)
    Cells(r, "D") = 數量.Text
End Sub
　

Function getStockQuote(ycode As Range)
'自訂函數自動重算
'如果不想自動重算，請刪除Application.Volatile
    Application.Volatile
    Dim x1 As String, x2 As String, x As String
    With CreateObject("Msxml2.XMLHTTP")
        '使用GET方法取得網頁原始碼
        x = "http://tw.stock.yahoo.com/d/s/company_" _
                & ycode.Value & ".html"
        .Open "GET", x, False
        .send
        '使用Split來取得股東權益報酬率

        x1 = "股東權益報酬率"
        x2 = "<td align=" & """" & "center" & """" & ">"
        getStockQuote = Split(Split(Split( _
                .responsetext, x1)(1), x2)(1), "</td")(0)
    End With
End Function

Microsoft.XMLHttp的屬性和方法的簡介及使用

Sub SendGmail()
    Dim Folder(), Filename()
    Dim iMsg As Object, iConf As Object
    Dim Flds As Object
    '使用 CDO 物件來傳送電子郵件
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    Set Flds = iConf.Fields
    schema = "http://schemas.microsoft.com/cdo/configuration/"
    Flds.Item(schema & "sendusing") = 2
    'gmail
    Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
    'gmail SMTP Server的Port為25，465和587
    Flds.Item(schema & "smtpserverport") = 465
    Flds.Item(schema & "smtpauthenticate") = 1
    '請改為你的gmail帳號
    Flds.Item(schema & "sendusername") = "你的gmail帳號@gmail.com"
    '請改為你的gmail密碼
    Flds.Item(schema & "sendpassword") = "你的gmail密碼"
    Flds.Item(schema & "smtpusessl") = 1
    Flds.Update
    With iMsg
        '收件人的電子郵件，可用分號；或逗號，斷開成多位收件人
        .To = "chijanzen@gmail.com"
        '寄件人的電子郵件信箱
        '請填入你要郵寄的mail
        .From = "chijanzen <chijanzen@gmail.com>"
        '郵件的主旨
        .Subject = "VBA 發送Gmail 測試"
        '郵件的本文-HTML模式
        .HTMLBody = "<h1>這是測試郵件!</h1>"
        '調用開啟舊檔對話方塊，按Ctrl鍵可以複選檔案
        sDir = Application.GetOpenFilename("All Files (*.*), *.*", , , , True)
        If TypeName(sDir) = "Boolean" Then GoTo 10    '按取消時不夾帶附件
        ReDim Preserve Folder(UBound(sDir))
        ReDim Preserve Filename(UBound(sDir))
        '依序附加檔案
        For i = 1 To UBound(sDir)
            .AddAttachment sDir(i)
        Next
10:         Set .Configuration = iConf
        '送出郵件
        SendEmailGmail = .Send
    End With
    MsgBox "郵件已傳送完成"
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End Sub

• Subject 郵件的主旨
• From 寄件人的電子郵件信箱
• To 收件人的電子郵件，可用分號；或逗號，斷開成多位收件人
• CC 副本收件人的電子郵件，可用分號；或逗號，斷開成多位收件人
• BCC 密送副本收件人的電子郵件，可用分號；或逗號，斷開成多位收件人
• TextBody 郵件的本文-純文字模式
• HTMLBody 郵件的本文-HTML模式

Sub test()
    Dim Asht As Worksheet, wbk As Workbook
    Dim c As Range, Frng As Range
    fn = ThisWorkbook.Path & "\aa.xls"
    Set Asht = Sheets("Sheet1")
    '以唯獨方式開啟aa.xls
    Set wbk = Workbooks.Open(fn, ReadOnly:=True)
    wbk.Activate
    '從第一列開始複製
    i = 1
    '被搜尋關鍵字
    txt = "2012"
    '歷遍 aa.xls 所有 Sheets
    For Each sht In wbk.Worksheets
        With sht.Cells
        '開始尋找
            Set c = .Find(txt, LookIn:=xlValues)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                '找到資料後開始複製
                    Set Frng = c.Offset(0, 1).Resize(40, 30)
                    Frng.Copy Asht.Cells(i, "A")
                    i = i + 40
                    Set c = .FindNext(c)  '同一個Sheet 尋找下一筆
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With
    Next
    '關閉aa.xls，不存檔
    wbk.Close False
End Sub

Sub Gt_Word()
    Dim wdApp As Object
    On Error Resume Next
    '引用一個現存的 Application 對象
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then    'Word 尚未開啟
    '引用一個新的，外部可創建的對象
        Set wdApp = CreateObject("Word.Application")
    End If
    wdApp.Visible = True
    '切換到 Word
    wdApp.Activate
End Sub

用 GetObject 賦值對象引用的幫助(VBA)

雖然 GetObject 函數也能用於賦值對一個新對象的引用，但是它一般還是用於賦值對已經存在的對象的引用。

使用下列語法，賦值對現存的對象的引用。

Set objectvariable = GetObject([pathname] [, progID])

pathname 參數可能是一個現存文件的路徑、一個空字符串，也可以完全省略。如果被省略，則要求 progID。指定一個現存文件的路徑，將引起 GetObject 使用存於文件中的信息創建一個對象。如第一個參數為空字符串，則 GetObject 的作用與 CreateObject 一樣，將創建編程標識符是 progID 的類的一個新對象。下列表格描述了使用 GetObject 的結果。

Set X = GetObject(, "MySrvr.Application")

例如，變量 wrdApp 引用一個正在運行的 Microsoft Wor Applicatdion：

Dim wdApp As Word.Application
Set wdApp = GetObject("", "Word.Application")

同 CreateObject 一樣，參數 "Word.Application" 是一個由 Microsoft word 定義的 Application 類的編程標誌符。如果有多個 Microsoft Word 實例在運行，不能預先指出 wdApp 將引用那個實例。

重點 可以用 GetObject 賦值對復合文檔文件中的對象引用。一個復合文檔文件含有對多個對象類型的引用。例如，一個復合文檔文件可以含有電子數據表，文本與位圖。

如果電子數據表應用程序還沒有運行，下列例子就啟動該程序並打開文件 Revenue.xls:

Dim xlBook As Excel.Workbook
Set xlBook = GetObject("C:\Accounts\Revenue.xls")