雲端資料庫

全區目錄

2017-12-11T04:22:00.002-08:00

Excel VBA 使用函數範例參考之六

2012-08-13T23:46:00.002-07:00

自定義菜單
　　把建立和刪除自定義菜單的代碼分別寫在Workbook_open和Workbook_beforeclosed
　　的事件中。
　　應該用VBA，工作薄代碼中有workbook-open()過程，在該過程中寫入
　　with activeworkbook
　　.sheets("表2").active
　　end with
　　VBA實現向鎖定工作表中插入行,並自動複制上面行中指定列的函數
　　Option Explicit
　　Public Const strPass = "123" 123是口令
　　Sub 行上再插入一行()
　　ActiveSheet.Unprotect password:=strPass
　　Selection.Copy
　　Selection.Insert Shift:=xlDown
　　Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,
　　SkipBlanks:= _
　　False, Transpose:=False
　　Application.CutCopyMode = False
　　ActiveSheet.Protect password:=strPass
　　End Sub
　　如何使不出現每次關閉XLS文件時出現的：
　　“XXX.xls檔已被修改，是否可在其修改後的內容？”字樣？？
　　可以在工作表關閉之前進行手工保存工作
　　ThisWorkbook.save
　　如何實現動態時間顯示?
　　sub mytime
　　range("a1")=now()
　　Application.OnTime Now + Timevalue("00:00:01"), "mytime"
　　end sub
　　用 vba 判斷指定 excel 檔是否打開？
　　For Each w In Workbooks
　　If w.Name XXX Then
　　…………
　　End If
　　Next w
　　vba怎麽調用excel自帶的函數?比如vlookup?
　　Application.WorksheetFunction.f(x)
　　f(x)是你想使用的工作表函數
　　但是用內部函數時引用單元格會出錯，怎麽辦？
　　把你要引用的單元格改成VBA認可格式（類型）。如在Excel中的“F7:F12”應改爲
　　“Range("F7:F12")”等。
　　VBA中如何關閉,保存和退出Excel?
　　Workbooks("你的工作簿").Save。
　　下表舉例說明瞭使用 Rows 和 Columns 屬性的一些行和列的引用。
　　引用含義
　　Rows(1) 第一行
　　Rows 工作表上所有的行
　　Columns(1) 第一列
　　Columns("A") 第一列
　　Columns 工作表上所有的列
　　若要同時處理若幹行或列，請創建一個對象變量並使用 Union 方法，將對 Rows 屬
　　性或 Columns 屬性的多個調用組合起來。下例將活動工作簿中第一張工作表上的第
　　一行、第三行和第五行的字體設置爲加粗。
　　Sub SeveralRows()
　　Worksheets("Sheet1").Activate
　　Dim myUnion As Range
　　Set myUnion = Union(Rows(1), Rows(3), Rows(5))
　　myUnion.Font.Bold = True
　　End Sub
　　如果只是你說的只連接幾個儲存格那用簡單的方法
　　Range("A1").Formula = Application.Evaluate("=[Book2.xls]Sheet1!A1")
　　或
　　Range("A1").Formula = "=[Book2.xls]Sheet1!A1"
　　請問在vba如何呼叫已定義的名稱範圍
　　我在a1:b100插入名稱∶myrange
　　請問我如何用vba選取此範圍
　　Range("myrange").Select
　　如何訪問沒有打開的EXCEL文件？
　　Sub AlternativeImport()
　　Dim xlapp As Excel.Application
　　Dim wbSource As Excel.Workbook
　　Set xlapp = New Excel.Application
　　xlapp.EnableEvents = False
　　Set wbSource = xlapp.Workbooks.Open("C:\test\Book2.xls")
　　Range("A1:A10").Value = wbSource.Sheets("Sheet1").Range
　　("A1:A10").Value
　　wbSource.Close False
　　xlapp.Quit
　　End Sub
　　怎樣使VBAprject工程不可查看？（不用密碼）
　　用可編輯十六進制文件的軟件工具（如WinHex等）打開Excel.xls,在文件的尾部,查
　　找ID="{00000000-0000-0000-0000-000000000000}"(有工程鎖定密碼時),或
　　ID="{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}"(沒有工程鎖定密碼時),修改其中
　　的任意1位後,保存,即可達到目的.當查看工程是會出現“工程不可查看”的提示.
　　注意:修改前,一定要備份原文件,以防不測
　　如何用VBA控制報表的格式（左邊距，紙張大小，列印第幾頁等）
　　列印第幾頁控制:ActiveWindow.SelectedSheets.PrintOut From:=x, To:=y
　　ActiveSheet.PageSetup.LeftMargin= 左邊距
　　ActiveSheet.PageSetup..PaperSize = 紙張大小
　　如何使VBA自動消除使用COPY複制後産生的虛線框？
　　Application.CutCopyMode = False
　　替換Excel 97的菜單欄是很容易的，只需創建一個新的菜單欄就會刪除Excel 97的
　　菜單欄。當需要恢複Excel 97的菜單欄時，只要刪除新創建的菜單欄就可以了。該
　　系統的自定義菜單中只需兩個命令按鈕，一個用來返回到系統的主畫面
　　（ReturnMAIN），另一個用來退出系統（ExitSYS）。下麵是模塊（Module）中有關
　　的巨集或是事件控制程式。
　　Sub ZapMenu( )
　　On Error Resume Next
　　CommandBars(“保險查詢系統”).Delete
　　End Sub
　　這是一個用來刪除自定義菜單欄的宏。語句On Error Resume Next保證無論自
　　定義菜單欄是否存在都能正確刪除它。
　　Sub ExitSYS( )
　　ZapMenu
　　ActiveWorkbook.Close SaveChanges := False
　　End Sub
　　這是用來退出系統的宏。它刪除自定義菜單，並關閉活動的工作簿（不提示保存
　　修改）。
　　Sub ReturnMAIN( )
　　Worksheets(“保險查詢系統”).Select
　　End Sub
　　該宏用來返回主畫面。它啟動“保險查詢系統”工作表。
　　Sub SetMenu( )
　　Dim myBar As CommandBar
　　Dim myButton As CommandBarButton
　　ZapMenu
　　Set myBar = CommandBars.Add(Name:=“保險查詢系統”, _
　　Position :=msoBarTop, _
　　MenuBar :=True)
　　Set myButton = myBar.Controls.Add(msoControlButton)
　　myButton. = msoButtonCaption
　　myButton.Caption = “退出[&E]”
　　myButton.OnAction = “ExitSYS”
　　Set myButton = myBar.Controls.Add(msoControlButton)
　　myButton. = msoButtonCaption
　　myButton.Caption = “返回[&R]”
　　myButton.OnAction = “ReturnMAIN”
　　myButton.Visible = False
　　myBar.Protection = msoBarNoMove + msoBarNoCustomize
　　myBar.Visible = True
　　End Sub
　　這個巨集包含五部分。第一部分定義了一對變量。第二部分首先運行ZapMenu巨集，
　　保證保險查詢系統菜單欄是不存在的，然後創建它。參數MenuBar的值設爲True，確
　　保這個新創建的命令欄爲一菜單欄。第三部分和第四部分將兩個命令按鈕加入到菜單
　　欄中。並設置ReturnMAIN命令按鈕的初始狀態爲不可見狀態。最後一部分保護這個
　　新創建的菜單欄，使用戶不能移動也不能自定義新菜單欄。
　　工作表彙總
　　Sub sum() '表彙總,第1張的a1:e20等於所有表的相同單元格的和
　　Attribute sum.VB_ProcData.VB_Invoke_Func = "z\n14"
　　Dim X As Worksheet
　　For y = 1 To 20
　　For z = 1 To 5
　　For Each X In Worksheets
　　shname = X.Name
　　ActiveSheet.Cells(y, z).Value = ActiveSheet.Cells(y, z).Value +
　　Worksheets(shname).Cells(y, z)
　　Next
　　Next z
　　Next y
　　End Sub(王朝網路 wangchao.net.cn)
補充說明:
在我們日常使用Excel的時候，不僅會用到當前Excel文件的數據，還經常需要訪問其他的數據文件。這些數據文件可能是Excel文件、文本文件或數據庫文件等。經常有朋友會問如何在vba代碼裏操作這些數據文件？本文就系統地介紹一下在Excel中應用VBA操作數據文件的方法。
　　本文主要介紹四種常用的方法：
　　1、利用Excel對象來處理文件；
　　2、利用VBA文件處理語句來處理文件；
　　3、利用FileSystemObject對象來處理文件；
　　4、利用API函數來處理文件。
　　當然對于數據庫文件，還可以利用ADO＋SQL的方法操作，不過論壇已經有前輩詳細介紹過此類方法，本文就不再重複了。
　　一、利用Excel對象來處理文件
　　利用Excel對象自帶的方法來操作文件是最方便，也是最簡單的。
　　我們主要利用Workbooks集合和Workbook對象的方法來操作文件。
　　1、打開Excel文件
　　我們可以用Workbooks.Open方法打開一個Excel工作簿。
　　Workbooks.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad)
　　其中FileName是必選的參數，表示要打開的工作簿名，如果沒有指定路徑，則代表當前路徑。另外14個是可選參數，除了密碼參數，其他的一般很少用。具體的含義可以參看VBA的幫助。
　　例：
　　 Workbooks.Open "F:\test.xls"
　　可以打開F盤的test.xls文件。
　　2、打開文本文件
　　使用Open方法也可以打開文本文件，但建議使用OpenText方法。此方法是載入一個文本文件，並將其作爲包含單個工作表的工作簿進行分列處理，然後在此工作表中放入經過分列處理的文本文件數據。完整語法如下：
　　Workbooks.OpenText(FileName, Origin, StartRow, DataType, TextQualifier, ConsecutiveDelimiter, Tab, Semicolon, Comma, Space, Other, OtherChar, FieldInfo, TextVisualLayout, DecimalSeparator, ThousandsSeparator, TrailingMinusNumbers, Local)
　　關于以上參數的具體含義可以參看VBA的幫助，這裏就不重複了。在實際的編程中，一般無需對這些複雜的參數進行處理。可以通過錄制宏來得到打開一個文本文件的VBA代碼。具體方法就是選擇“文件——打開”，然後選擇打開文本文件，就會出現文本導入向導，一步一步執行完，直到文本打開後，停止錄制。
　　以下是錄制宏得到的代碼:
　　Sub Macro1()
　　'
　　' Macro1 Macro
　　' 宏由 MC SYSTEM 錄制，時間: 2007-3-29
　　'
　　'
　　 Workbooks.OpenText Filename:="F:\CallWindowProc.txt", Origin:=xlWindows, _
　　 StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
　　 ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
　　 , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
　　 TrailingMinusNumbers:=True
　　End Sub
　　在實際編程中只要做相應的修改就可以使用了。
　　3、打開其他文件
　　利用Excel對象還可以打開XML文件和一些數據庫（如Access）文件，對應XML文件，需要Excel2003以上的版本。
　　OpenXML方法的語法如下：
　　Workbooks.OpenXML(Filename, Stylesheets, LoadOption)
　　FileName String 類型，必需。要打開的文件名。
　　Stylesheets Variant 類型，可選。單個值或值的數組，用于指定要應用哪些 XSL 轉換 (XSLT) 樣式表處理指令。
　　LoadOption Variant 類型，轉換。指定 Excel 打開 XML 數據文件的方式。可爲 XlXmlLoadOption 常量之一。
　　XlXmlLoadOption 可爲以下 XlXmlLoadOption 常量之一：
　　xlXmlLoadImportToList 將 XML 數據文件的內容置于 XML 列表中。
　　xlXmlLoadMapXml 在“XML 結構”任務窗格中顯示 XML 數據文件的架構。
　　xlXmlLoadOpenXml 打開 XML 數據文件。文件的內容將展開。
　　xlXmlLoadPromptUser 提示用戶選擇打開文件的方式。
　　示例
　　下面的代碼打開了 XML 數據文件“customers.xml”並在 XML 列表中顯示了此文件的內容。
　　Sub UseOpenXML()
　　 Application.Workbooks.OpenXML _
　　 Filename:="customers.xml", _
　　 LoadOption:=xlXmlLoadImportToList
　　End Sub
　　OpenDatabase 方法語法如下：
　　Workbooks.OpenDatabase(FileName, CommandText, CommandType, BackgroundQuery, ImportDataAs)
　　FileName String 類型，必需。連接字符串。
　　CommandText Variant 類型，可選。查詢的命令文本。
　　CommandType Variant 類型，可選。查詢的命令類型。以下是可用的命令類型：Default、SQL 和 Table。
　　BackgroundQuery Variant 類型，可選。查詢的背景。
　　ImportDataAs Variant 類型，可選。確定查詢的格式。
　　示例
　　本示例中，Excel 打開了“northwind.mdb”文件。
　　Sub OpenDatabase()
　　Workbooks.OpenDatabase FileName:="C:\northwind.mdb"
　　End Sub
　　4、保存文件
　　文件的保存使用Workbook對象的Save或SaveAs方法。
　　Save方法使用簡單，語法爲
　　expression.Save，expression是某個Workbook對象。
　　如：ActiveWorkbook.Save
　　即保存當前活動工作簿。
　　如果是第一次保存工作簿或要另存爲，請使用 SaveAs 方法爲該文件指定文件名。
　　其語法爲：
　　expression.SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local)
　　具體參數含義可參看VBA幫助，使用都比較簡單。
　　示例
　　本示例新建一個工作簿，提示用戶輸入文件名，然後保存該工作簿。
　　Set NewBook = Workbooks.Add
　　Do
　　 fName = Application.GetSaveAsFilename
　　Loop Until fName <> False
　　NewBook.SaveAs Filename:=fName
　　Application.GetSaveAsFilename爲調出標准的“另存爲”對話框，獲取用戶文件名，但並不真正保存任何文件，然後使用代碼保存文件。還有Application.GetOpenFileName可以調出標准的“打開”對話框。
　　5、關閉文件
　　關閉文件可以使用Workbooks集合或Workbook對象的 Close 方法。前者是關閉所有打開的工作簿，後者關閉特定的工作簿。
　　Workbook對象的 Close 方法語法爲：
　　expression.Close(SaveChanges, Filename, RouteWorkbook)
　　SaveChanges參數表示是否保存更改，對許多不需要更改的操作，可設置爲False以免彈出保存更改提示的對話框。
　　FileName 可選。以此文件名保存所做的更改。
　　RouteWorkbook 可選。如果指定工作簿不需要傳送給下一個收件人（沒有傳送名單或已經傳送），則忽略該參數。
　　示例
　　本示例關閉 Book1.xls，並放棄所有對此工作簿的更改。
　　Workbooks("BOOK1.XLS").Close SaveChanges:=False
　　
　　本示例關閉所有打開的工作簿。如果某個打開的工作簿有改變，Microsoft Excel 將顯示詢問是否保存更改的對話框和相應提示。
　　Workbooks.Close
　　6、綜合實例
　　假如F盤有一個Excel文件test.xls，現在有另一個Excel文件要訪問test.xls的數據，我們來看用VBA代碼如何操作。代碼如下：
　　Public Sub test()
　　Application.ScreenUpdating = False
　　Workbooks.Open "f:\test.xls"
　　ThisWorkbook.Sheets(1).Range("b1") = ActiveWorkbook.Sheets(1).Range("a2")
　　ActiveWorkbook.Close
　　Application.ScreenUpdating = True
　　End Sub
　　首先關閉屏幕刷新，是爲了防止test.xls在打開時被看見(有時候還是看的見）。打開後，見test.xls的Sheet1的單元格A2中的值賦給當前工作簿的Sheet1的單元格B2，然後關閉test.xls。
　　當要打開的工作簿不確定的時候，可以通過調用打開對話框來讓用戶自己選擇。
　　可改爲如下：
　　Public Sub test()
　　Application.ScreenUpdating = False
　　Dim Filename as String
　　Filename = Application.GetOpenFileName
　　Workbooks.Open Filename
　　ThisWorkbook.Sheets(1).Range("b1") = ActiveWorkbook.Sheets(1).Range("a2")
　　ActiveWorkbook.Close
　　Application.ScreenUpdating = True
　　End Sub
　　7、總結
　　利用Excel對象的方法進行文件操作是最簡單，也是最方便的，適合初學者。對于Excel文件格式，如果我們僅僅是讀取其表格中的內容，這種方法也是首選。對于文本文件的操作，使用第二種方法比較方便，若要將文本轉換成表格，那麽使用此方法也是合適的.

Excel VBA 使用函數範例參考之五

2012-08-13T23:44:00.002-07:00

本示例重複最近用戶介面命令。本示例必須放在宏的第一行。
　　Application.Repeat
　　下例中，變量 counter 代替了行號。此過程將在單元格區域 C1:C20 中循環，將所
　　有絕對值小於 0.01 的數字都設置爲 0（零）。
　　Sub RoundToZero1()
　　For Counter = 1 To 20
　　Set curCell = Worksheets("Sheet1").Cells(Counter, 3)
　　If Abs(curCell.Value) 0 Then
　　' Application.ActivePrinter = "\zdserver2HP LaserJet 5000 PCL 6
　　在 Ne00:" '指定列印機
　　ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum,
　　Collate:=True '設置列印資訊,其中Copies:=myPrint爲列印份數
　　Else
　　MsgBox "請輸入要列印的份數"
　　End If
　　ActiveSheet.ShowAllData '全部顯示
　　ActiveSheet.Protect Password:=641112 ' 保護工作表並設置密碼
　　Sheets("封面").Select
　　Application.ScreenUpdating = True
　　End Sub
　　Sub 列印餘額()
　　Application.ScreenUpdating = False
　　Sheets("餘額表").Select
　　Call 重算所有表
　　ActiveSheet.Unprotect Password:=641112 '撤銷工作表保護並取消密碼
　　ActiveWindow.ScrollColumn = 10
　　Selection.AutoFilter Field:=1, Criteria1:=""
　　'以下10行彈出視窗輸入列印資訊
　　Dim myPrintNum As Integer
　　Dim myPrompt, myTitle As String
　　myPrompt = "請輸入要列印的份數"
　　myTitle = "列印選取範圍"
　　myPrintNum = Application.InputBox(myPrompt, myTitle, 4, , , , , 1)
　　If myPrintNum 0 Then
　　' Application.ActivePrinter = "\zdserver2HP LaserJet 5000 PCL 6 在
　　Ne00:" ' '指定列印機
　　ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum,
　　Collate:=True '設置列印資訊,其中Copies:=myPrint爲列印份數
　　Else
　　MsgBox "請輸入要列印的份數"
　　End If
　　ActiveSheet.ShowAllData '全部顯示
　　ActiveSheet.Protect Password:=641112 ' 保護工作表並設置密碼
　　Sheets("封面").Select
　　Application.ScreenUpdating = True
　　End Sub
　　Sub 備份()
　　Dim y '變量聲明-需保存工作表的路徑和名稱
　　[M1] = ActiveWorkbook.FullName '單元格M1=當前工作簿的路徑和名稱
　　y = cells(1, 14) 'Y=單元格N1的值,即計算後的需保存工作簿的
　　路徑和名稱
　　Worksheets("封面").UsedRange.Columns("M:N").Calculate '計算指定
　　區域
　　ActiveWorkbook.SaveCopyAs y '備份到指定路麽Y
　　End Sub
　　Sub 重算活動表()
　　With Application
　　.Calculation = xlManual
　　.MaxChange = 0.001
　　End With
　　ActiveWorkbook.PrecisionAsDisplayed = True
　　ActiveWindow.DisplayZeros = True
　　ActiveSheet.Calculate
　　End Sub
　　Sub 重算指定表()
　　Attribute 重算指定表.VB_ProcData.VB_Invoke_Func = "z\n14"
　　Worksheets("銀行帳").Calculate
　　Worksheets("日報表").Calculate
　　End Sub
　　單元格數據改變引起計算啟動過程
　　Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim irow, icol As Integer
　　irow = Target.Row '變量行irow
　　icol = Target.Column '變量列icol
　　If irow > 6 And icol = 3 And cells(irow, 3) >= cells(irow - 1, 3)
　　Then '>大於6行,並且第3列,當本行 3列>2行3列
　　Application.EnableEvents = False
　　cells(irow, 2) = cells(irow - 1, 2) '本行 2 列=上一行2列
　　Application.EnableEvents = True
　　ElseIf irow > 6 And icol = 3 And cells(irow, 3) 大於6行,並且第3列,當本行 3列>2行3列
　　Application.EnableEvents = False
　　cells(irow, 2) = cells(irow - 1, 2) + 1 '本行 2 列=上行2列+1
　　Application.EnableEvents = True
　　ElseIf (icol = 3 Or icol = 4 Or icol = 6 Or icol = 8 Or icol = 9 Or
　　icol = 10 Or icol = 12 Or icol = 13) And irow > 6 Then 'And Target
　　""
　　Application.EnableEvents = False
　　cells(irow, 5) = "=單位名稱"
　　cells(irow, 7) = "=摘要"
　　cells(irow, 11) = "=餘額"
　　Range(cells(irow, 14), cells(irow, 16)) = "=預內外收支NOP"
　　cells(irow, 17) = "=審核Q"
　　cells(irow, 18) = "=對帳U"
　　Range(cells(irow, 19), cells(irow, 20)) = "=內轉收支XY"
　　cells(irow, 21) = "=政采Z"
　　Application.EnableEvents = True
　　End If
　　End Sub
　　'計算當前工作表路徑及名稱的函數,可作爲單元格公式,也可寫入宏
　　=CELL("FILENAME")
　　'改變Excel介面標題的巨集
　　Private Sub Workbook_Open()
　　Application.Caption = "吃過了"
　　End Sub
　　'自動刷新單元格A1內顯示的日期\時間的宏
　　Sub mytime()
　　Range("a1") = Now()
　　Application.OnTime Now + TimeValue("00:00:01"), "mytime"
　　End Sub
　　'用單元格A1的內容作爲檔案名保存當前工作簿的宏
　　Sub b()
　　ActiveWorkbook.SaveCopyAs Range("A1") + ".xls"
　　End Sub
　　'啟動窗體的巨集,此巨集寫入有窗體的工作表內
　　Private Sub CommandButton1_Click() '點數據錄入按鈕控制項啟動窗體
　　Load UserForm3 '啟動窗體
　　UserForm3.StartUpPosition = 3 '啟動窗體
　　UserForm3.Show '啟動窗體
　　End Sub
　　'以下爲窗體中點擊各按鈕運行的宏,寫入窗體內
　　Public pos As Integer '聲明變量pos
　　'戰友確定按鈕語句
　　Private Sub CommandButton1_Click()
　　Application.ScreenUpdating = False '此句和最後一句旨在不顯
　　示宏的執行過程
　　'On Error GoTo ErrorHandle '可以不要
　　'ErrorHandle: '可以不要
　　'If Err.Number = 13 Then '可以不要
　　'Exit Sub '可以不要
　　'End If '可以不要
　　Call writeToWorkSheet '執行宏writetoworksheet
　　UserForm3.Hide '退出窗體,繼續按鈕少此句,退出按鈕執行此句
　　Unload UserForm3 '退出窗體,繼續按鈕少此句,退出按鈕執行此句
　　Call 批量列印 '[此處到接順序2]
　　[L2] = "" '[到此處結束]
　　Sheets("列印資訊").Select
　　Application.ScreenUpdating = True
　　End Sub
　　'退出按鈕語句
　　Private Sub CommandButton2_Click()
　　UserForm3.Hide
　　Unload UserForm3
　　End Sub
　　'將窗體內的文字方塊中的數據寫進工作表的單元格
　　Private Sub writeToWorkSheet()
　　ActiveSheet.Range("k2") = TextBox1.Value '將文字框內容寫進k列
　　ActiveSheet.Range("l2") = TextBox2.Value '將文字框內容寫進l列
　　TextBox1.Value = "" '清空文字框內容
　　TextBox2.Value = "" '清空文字框內容
　　Worksheets("列印資訊").Range("a2").Value = 1 '給指定表的單元格寫入
　　數據
　　Worksheets("列印資訊").Range("B3:E113").Value = "" '清空指定表的單元
　　格數據
　　End Sub
　　'以下爲根據條件列印的宏
　　Sub 列印() '部門明細查詢及批星列印
　　Application.ScreenUpdating = False '關閉螢幕更新
　　If Cells(1, 4) = "" And Cells(1, 5) = "" Then '列印條件Cells(3,
　　13) = 1 And
　　' Application.ActivePrinter = "\zdserver2HP LaserJet 5000 PCL
　　6 在 Ne00:" ' '指定列印機
　　ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
　　'設置默認列印機的列印資訊,其中Copies:=myPrint爲列印份數
　　Else
　　Call 列印資訊 '打倒爲假時執行
　　End If
　　Application.ScreenUpdating = True '關閉螢幕更新
　　End Sub
　　'以下的循環過程,也用於批量列印,Z的值可以是Z=1 TO 5(1到5),也可是單元格的內
　　容
　　Sub 批量列印()
　　For Z = Cells(1, 11) To Cells(1, 12) '變量X的值從列印起始號K1到結束
　　號L1之間逐漸遞增
　　Cells(1, 13) = Z 'M1的值等於變量X
　　Next Z
　　End Sub
　　'以下是將列印情況寫入工作表的宏
　　Sub 列印資訊()
　　Application.ScreenUpdating = False '關閉螢幕更新
　　Dim Y '聲明變量
　　Y = ActiveSheet.Name '判定活動工作表名稱
　　Sheets("列印資訊").Select
　　X = 3 '從第3行開始
　　Do While Not (IsEmpty(Cells(X, 2).Value)) '判斷第1列的最後一行(
　　即空行的上一行)
　　X = X + 1 '在最後一行加一行即爲空行
　　Loop
　　Cells(X, 2) = Cells(2, 1)
　　Cells(X, 3) = Sheets(Y).Cells(4, 3)
　　Cells(2, 1) = Cells(2, 1) + 1
　　Cells(X, 4) = Sheets(Y).Cells(1, 4)
　　Cells(X, 5) = Sheets(Y).Cells(1, 5)
　　[c1] = Y
　　Sheets(Y).Select '返回上一次打開的工作表
　　Application.ScreenUpdating = True '打開螢幕更新
　　End Sub
　　將檔保存爲以某一單元格中的值爲檔案名的宏怎麽寫
　　假設你要以Sheet1的A1單元格中的值爲檔案名保存，則應用命令：
　　ActiveWorkbook.SaveCopyAs Str(Range("Sheet1!A1")) + ".xls"
　　在Excel中,如何用程式控制某一單元格不可編輯修改?thanks!!!
　　Private Sub Workbook_Open()
　　ProtectSpecialRange ("A1")
　　End Sub
　　Sub ProtectSpecialRange(RangeAddress As String)
　　On Error Resume Next
　　With Sheet1
　　.Cells.Locked = False
　　.Range(RangeAddress).Locked = True
　　.Protection.AllowEditRanges.Add Title:="區域1", Range:=Range
　　(RangeAddress) _
　　, Password:="pass"
　　.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
　　End With
　　End Sub
　　對工作表編程，有時要判斷工作表的記錄總數，VBA裏如何實現？
　　x=1
　　do while not (isempty(sheets("").cells(x,1).value)
　　x=x+1
　　loop
　　在VBA中等同于EXCELE中的求和函數-sum()-的函數是什麽?
　　Application.WorksheetFunction.Sum()
　　自定義菜單有三個菜單項，要求手工順序執行。爲防止誤操作，執行完第一個菜單項
　　後使其變灰（禁用），如何寫？
　　Rowen
　　令其 Enable屬性同步與某個工具按鈕是較爲方便的。
　　如何進行表格更新？
　　是這樣的，比如我已經有了一個原始表格A，這時有人通知我A表有錯誤，須加以修改
　　，並給我一個表B，表B列出了須修改的參數（注意B的列數少於A的列數，因A的其他
　　列無需修改）。現在問題是如何根據表B中的新值，在表A中找到相應位置，並加以修
　　改。比如表B中列出了10002的JOHN的身高和體重等值需要修改，如何在A中找到
　　10002的相應位置（身高體重），並加以修改。
　　建議將表b複製至表a的sheet2，然後執行下列的宏即可
　　sub change()
　　dim dd as range
　　sheets(2).select
　　lastcell = range("a65536").end(xlup).row
　　for each dd in range(cells(2, 1), cells(lastcell, 1))
　　if dd = "" then exit sub
　　ff = dd.value
　　set c = sheets(1).columns(1).find(ff, lookat:=xlwhole)
　　if not c is nothing then
　　c.offset(0, 2) = dd.offset(0, 2)
　　c.offset(0, 3) = dd.offset(0, 3)
　　c.offset(0, 5) = dd.offset(0, 4)
　　end if
　　next
　　end sub

Excel VBA 使用函數範例參考之四

2012-08-13T23:43:00.002-07:00

1）創建Excel對象
　　Excel對象模型包括了128個不同的對象，從矩形、文字方塊等簡單的對
　　象到透視表，圖表等複雜的對象。下面簡單介紹一下其中最重要，也是用
　　得最多的五個對象。
　　（1）Application對象
　　Application對象處於Excel對象層次結構的頂層，表示 Excel自身的
　　運行環境。
　　（2）Workbook對象
　　Workbook對象直接地處於Application對象的下層，表示一個Excel工
　　作薄文件。
　　（3）Worksheet對象
　　Worksheet對象包含於Workbook對象，表示一個Excel工作表。
　　（4）Range對象
　　Range對象包含於Worksheet對象，表示 Excel工作表中的一個或多個
　　單元格。
　　（5）Cells對象
　　Cells對象包含於Worksheet對象，表示Excel工作表中的一個單元格。
　　如果要啓動一個Excel，使用Workbook和Worksheet對象，下面的代碼
　　啓動了Excel並創建了一個新的包含一個工作表的工作薄：
　　Dim zsbexcel As Excel.Application
　　Set zsbexcel = New Excel.Application
　　zsbexcel.Visible = True
　　如要Excel不可見，可使zsbexcel.Visible = False
　　zsbexcel.SheetsInNewWorkbook = 1
　　Set zsbworkbook = zsbexcel.Workbooks.Add
　　2）設置單元格和區域值
　　要設置一張工作表中每個單元格的值，可以使用Worksheet對象的
　　Range屬性或Cells屬性。
　　With zsbexcel.ActiveSheet
　　.Cells(1, 2).value = "100"
　　.Cells(2, 2).value = "200"
　　.Cells(3, 2).value = "=SUM(B1:B2)"
　　.Range("A3:A9") = "中國人民解放軍"
　　End With
　　要設置單元格或區域的字體、邊框，可以利用Range對象或Cells對象
　　的Borders屬性和Font屬性：
　　With objexcel.ActiveSheet.Range("A2:K9").Borders '邊框設置
　　.Line = xlBorderLine
　　.Weight = xlThin
　　.ColorIndex = 1
　　End With
　　With objexcel.ActiveSheet.Range("A3:K9").Font'字體設置
　　.Size = 14
　　.Bold = True
　　.Italic = True
　　.ColorIndex = 3
　　End With
　　通過對Excel單元格和區域值的各種設置的深入瞭解,可以創建各種複
　　雜、美觀、滿足需要的、具有自己特點的報表。
　　3）預覽及列印
　　生成所需要的工作表後，就可以對EXCEL發出預覽、列印指令了。
　　zsbexcel.ActiveSheet.PageSetup.Orientation = xlPortrait '
　　設置列印方向
　　zsbexcel.ActiveSheet.PageSetup.PaperSize = xlPaperA4'
　　設置列印紙的打下
　　zsbexcel.Caption = "列印預覽" '設置預覽視窗的
　　標題
　　zsbexcel.ActiveSheet.PrintPreview'列印預覽
　　zsbexcel.ActiveSheet.PrintOut'列印輸出
　　通過列印方向、列印紙張大小的設置，不斷進行預覽，直到滿意爲止，
　　最終進行列印輸出。
　　爲了在退出應用程式後EXCEL不提示用戶是否保存已修改的檔,需使
　　用如下語句：
　　zsbexcel.DisplayAlerts = False
　　zsbexcel.Quit '退出EXCEL
　　zsbexcel.DisplayAlerts = True
　　如此設計的報表列印是通過 EXCEL程式來後台實現的。對於使用者來
　　說，根本看不到具體過程，只看到一張張漂亮的報表輕易地被列印出來了。
　　4）具體實例
　　下麵給出一個具體實例，它在window98、Visual Basic 6.0、
　　Microsoft Office97的環境下調試通過。
　　在VB中啓動一個新的Standard EXE工程，在“工程”菜單的“引用”
　　選項下引用Excel Object Library；然後在Form中添加一個命令按鈕
　　cmdExcel；最後在窗體中輸入如下代碼：
　　Dim zsbexcel As Excel.Application
　　Private Sub cmdExcel_Click()
　　Set zsbexcel = New Excel.Application
　　zsbexcel.Visible = True
　　zsbexcel.SheetsInNewWorkbook = 1
　　Set zsbworkbook = zsbexcel.Workbooks.Add
　　With zsbexcel.ActiveSheet.Range("A2:C9").Borders'邊框設置
　　.Line = xlBorderLine
　　.Weight = xlThin
　　.ColorIndex = 1
　　End With
　　With zsbexcel.ActiveSheet.Range("A3:C9").Font'字體設置
　　.Size = 14
　　.Bold = True
　　.Italic = True
　　.ColorIndex = 3
　　End With
　　zsbexcel.ActiveSheet.Rows.HorizontalAlignment =
　　xlVAlignCenter'水準居中
　　zsbexcel.ActiveSheet.Rows.VerticalAlignment =
　　xlVAlignCenter'垂直居中
　　With zsbexcel.ActiveSheet
　　.Cells(1, 2).value = "100"
　　.Cells(2, 2).value = "200"
　　.Cells(3, 2).value = "=SUM(B1:B2)"
　　.Cells(1, 3).value = "中國人民解放軍"
　　.Range("A3:A9") = "50"
　　End With
　　zsbexcel.ActiveSheet.PageSetup.Orientation = xlPortrait '
　　xlLandscape
　　zsbexcel.ActiveSheet.PageSetup.PaperSize = xlPaperA4
　　zsbexcel.ActiveSheet.PrintOut
　　zsbexcel.DisplayAlerts = False
　　zsbexcel.Quit
　　zsbexcel.DisplayAlerts = True
　　Set zsbexcel = Nothing
　　提高EXCEL中VBA的效率
　　方法1：盡量使用VBA原有的屬性、方法和Worksheet函數
　　由於Excel對象多達百多個，對象的屬性、方法、事件多不勝數，對于初學者來
　　說可能對它們不全部瞭解，這就産生了編程者經常編寫與Excel對象的屬性、方法相
　　同功能的VBA代碼段，而這些代碼段的運行效率顯然與Excel對象的屬性、方法完成
　　任務的速度相差甚大。例如用Range的屬性CurrentRegion來返回 Range 對象，該對
　　象代表當前區。（當前區指以任意空白行及空白列的組合爲邊界的區域）。同樣功能
　　的VBA代碼需數十行。因此編程前應盡可能多地瞭解Excel對象的屬性、方法。
　　充分利用Worksheet函數是提高程式運行速度的極度有效的方法。如求平均工資
　　的例子：For Each c In Worksheet(1).Range(″A1:A1000″)
　　Totalvalue = Totalvalue ＋ c.value
　　Next
　　Averagevalue = Totalvalue / Worksheet(1).Range(″
　　A1:A1000″).Rows.Count
　　而下面代碼程式比上面例子快得多：
　　Averagevalue="/blog/Application.WorksheetFunction.Average(Worksheets
　　(1).Range(″A1:A1000″))
　　其它函數如Count,Counta,Countif,Match,Lookup等等，都能代替相同功能的
　　VBA程式代碼，提高程式的運行速度。
　　方法2：盡量減少使用對象引用，尤其在循環中
　　每一個Excel對象的屬性、方法的調用都需要通過OLE介面的一個或多個調用，
　　這些OLE調用都是需要時間的，減少使用對象引用能加快VBA代碼的運行。例如
　　1．使用With語句。
　　Workbooks(1).Sheets(1).Range(″A1:A1000″).Font.Name=″Pay″
　　Workbooks(1).Sheets(1).Range(″A1:A1000″).Font.Font
　　...
　　則以下語句比上面的快
　　With Workbooks(1).Sheets(1).Range(″A1:A1000″).Font
　　.Name = ″Pay″
　　.Font = ″Bold″
　　...
　　End With
　　2．使用對象變量。
　　如果你發現一個對象引用被多次使用，則你可以將此對象用Set 設置爲對象變
　　量，以減少對對象的訪問。如：
　　Workbooks(1).Sheets(1).Range(″A1″).value = 100
　　Workbooks(1).Sheets(1).Range(″A2″).value = 200
　　則以下代碼比上面的要快：
　　Set MySheet = Workbooks(1).Sheets(1)
　　MySheet.Range(″A1″).value = 100
　　MySheet.Range(″A2″).value = 200
　　3．在循環中要盡量減少對象的訪問。
　　For k = 1 To 1000
　　Sheets(″Sheet1″).Select
　　Cells(k,1).value = Cells(1,1).value
　　Next k
　　則以下代碼比上面的要快：
　　Set Thevalue = Cells(1,1).value
　　Sheets(″Sheet1″).Select
　　For k = 1 To 1000
　　Cells(k,1).value = Thevalue
　　Next k
　　方法3：減少對象的啟動和選擇
　　如果你的通過錄制宏來學習VBA的，則你的VBA程式裏一定充滿了對象的啟動和選
　　擇，例如Workbooks(XXX).Activate、Sheets(XXX).Select、Range(XXX).Select等
　　,但事實上大多數情況下這些操作不是必需的。例如
　　Sheets(″Sheet3″).Select
　　Range(″A1″).value = 100
　　Range(″A2″).value = 200
　　可改爲：
　　With Sheets(″Sheet3″)
　　.Range(″A1″).value = 100
　　.Range(″A2″).value = 200
　　End With
　　方法4：關閉螢幕更新
　　如果你的VBA程式前面三條做得比較差，則關閉螢幕更新是提高VBA程式運行速度
　　的最有效的方法，縮短運行時間2/3左右。關閉螢幕更新的方法：
　　Application.ScreenUpdate = False
　　請不要忘記VBA程式運行結束時再將該值設回來：
　　Application.ScreenUpdate = True

Excel VBA 使用函數範例參考之三

2012-08-13T23:41:00.002-07:00

VBALesson 9 程式說明∶體會一下Worksheet_Change()事件連鎖反應。
　　Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim iRow As Integer
　　iRow = Target.Row
　　Application.EnableEvents = False
　　Cells(iRow, 3) = Cells(iRow, 3) + Cells(iRow, 2)
　　Application.EnableEvents = True
　　End Sub
　　Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim iRow As Integer
　　iRow = Target.Row
　　'Application.EnableEvents = False
　　Cells(iRow, 3) = Cells(iRow, 3) + Cells(iRow, 2)
　　'Application.EnableEvents = True
　　End Sub
　　這個程式的目的是要在 B2 輸入新的數?時，C2 會將 B2 輸入的新數?加上 C2 原
　　有的數?呈現在 C2 上。
　　照上面有加上 Application.EnableEvents = False 程式執行當然沒問題。
　　現在你在 Application.EnableEvents = False 與 Application.EnableEvents =
　　True 前加上「 '」看看。
　　程式前加上「 '」的目的是要使「 '」之後的文字變成說明文字，程式執行時是會跳
　　過說明文字，不執行說明文字的內容。
　　程式前加上「 '」符號後，文字會變成綠色。
　　執行第二個程式時，你將發現 C2 不會按你所要求的，呈現結果。
　　這就是所謂的事件連鎖反應。
　　請問這個宏該如何寫!
　　我想運行一個宏,就能在當前工作表B3上填上一條公式;這條公式的結果是所有工作
　　表上的B4單元格的和.請問這個宏該如何寫.謝謝!
　　Sub gg()
　　Dim sh As Worksheet, shname$
　　For Each sh In Worksheets
　　shname = sh.Name
　　ActiveSheet.Range("b3").value = ActiveSheet.Range("b3").value +
　　Worksheets(shname).Range("b4")
　　Next
　　End Sub
　　VBA中怎樣創建一個名爲“table”的新工作表
　　通過VBA編程，很容易添加新的工作表，但是新表的名字不知怎樣控制，對於新創建
　　的工作表，由於其名字並非特定，所以就不好使用所創建的新表了。不知各位有何高
　　見。。。。
　　Sheets.Add
　　ActiveSheet.Name = "table"
　　請教：如何用VBA檢索表1中A列與表2，3，4，5.....中A列相同的行並把後者整行拷
　　貝到表1檢索到的行中,謝謝!!!!
　　To yxptwq∶用這程式試看看。
　　Sub Copy1()
　　Dim Row_dn1, Row_dnN, i, j, n As Integer
　　Row_dn1 = Sheet1.Range("A65536").End(xlUp).Row
　　k = 1: n = 1
　　For Each wSheet In ActiveWorkbook.Worksheets
　　With wSheet
　　If .Name "Sheet1" Then
　　Row_dnN = .Range("A65536").End(xlUp).Row
　　For i = 2 To Row_dn1
　　For j = 2 To Row_dnN
　　If .Cells(j, 1) = Sheet1.Cells(i, 1) Then
　　.Rows(j & ":" & j).Copy Destination:=Sheet1.Rows(Row_dn1 +
　　n & ":" & Row_dn1 + n)
　　n = n + 1
　　End If
　　Next j
　　Next i
　　End If
　　End With
　　Next wSheet
　　End Sub
　　如果要用VBA程式輸入密碼使用下列程式碼
　　Sub EnterNewPW()
　　'程式說明:利用SendKey輸入VBAProject密碼
　　'注意事項:執行本程式需要在Excel視窗,不能在VBE視窗
　　Application.SendKeys "%{F11}", True 'Alt + F11 切換到VBA視窗
　　Application.SendKeys "%T", True 'ALT + T 工具(繁體中文是(T))
　　Application.SendKeys "e", True '工具(T)-VBproject屬性(E)
　　Application.SendKeys "^{TAB}", True 'TAB 鍵(切換到PAge2 保護頁面)
　　Application.SendKeys "{+}", True '選取Checkbox方塊(鎖定專案以供檢
　　視)
　　'({+} 選取, {-} 取消選取)
　　Application.SendKeys "{TAB}", True 'TAB 鍵(跳到第一次輸入密碼
　　Textbox
　　myPW = "chijanzen" '假設密碼 chijanzen
　　Application.SendKeys myPW, True '輸入密碼
　　Application.SendKeys "{TAB}", True 'TAB 鍵(跳到第二次輸入密碼
　　Textbox
　　Application.SendKeys myPW, True '輸入密碼
　　Application.SendKeys "{ENTER}", True '按確定鈕(預設值)
　　Application.SendKeys "%{F11}", True '返回Excel視窗
　　End Sub
　　冒泡排序法：
　　冒泡排序法之所以成爲“冒泡排序”是因爲值較小的或是較輕的元素浮到作爲繼續排
　　序的一組數的頂部。
　　Sub Macro1()
　　Dim i As Integer
　　Dim j As Integer
　　Dim t as integer
　　Static number(1 To 10) As Integer
　　For i = 1 To 10
　　number(i) = inputbox“輸入要排序的數：”
　　Next i
　　For i = 10To 2 Step -1
　　For j = 1 To i – 1
　　‘下面進行位置交換
　　If number(j) > number(j + 1) Then
　　t = number(j + 1)
　　number(j + 1) = number(j)
　　number(j) = t
　　End If
　　Next j
　　Next i
　　For i = 1 To 20
　　Print number(i)
　　Next i
　　End sub
　　首先定義一個數組：通過循環錄入10個整數，然後用一個二重循環測試前一個數是否
　　大於後一個數。如果大於則交換兩個數的下標，即交換兩個數在數組中的位置，交換
　　通過一個變量來進行。
　　我先用傳統的方法解決這個問題，經過比較，選用了較爲簡單的和高效的排序方法
　　——“快速排序”，具體演算法可參考數據結構等有關書籍。對所有數據排序後再合
　　並相同數據，合並程式較爲簡便，我開始時採用了這種方法，但後來發現對於這些
　　的數據，先合並後排序速度更快，因爲有大量相同的數據。合並是採用“標記”算
　　法，具體如下：（設數據已存放在sData()數組中，結果存到Queryp()數組，
　　Amount是數據個數）
　　'把相同元素置 0
　　For i = 1 To Amount
　　If sData(i) 0 Then
　　For j = i ＋ 1 To Amount
　　If sData(i) = sData(j) Then sData(j) = 0
　　Next j
　　End If
　　Next i
　　'刪除相同元素
　　Queryp(1) = sData(1)
　　k = 1
　　For i = 2 To Amount
　　If Not (sData(i) = 0) Then
　　k = k ＋ 1
　　Queryp(k) = sData(i)
　　End If
　　Next i
　　kMax = k
　　ReDim Preserve Queryp(kMax)
　　雖然這樣使得運算速度有所高，但是仍然要進行大量的循環運算，占據了程式大部
　　分的運算時間。於是我一直在尋覓一種更爲高效的演算法。
　　功夫不負有心人，在仔細分析數據的特徵，比較了多種方案之後，我終於找到了一
　　種相當成功的演算法，原來要3到4秒的運算縮短到僅需0.1到0.2秒。
　　我遇到的數據具有以下特徵：①相同數據很多，②最大、最小數之間相差不到3，
　　③都是帶兩位小數的正數。
　　針對數據的特徵，我採用了以下演算法：
　　針對數據的特徵，我採用了以下演算法：
　　步驟：
　　1．用一個循環找出整數和小數部分的最大、最小值。小數部分的最大、最小值乘
　　以100轉爲整數。
　　2．定義一個二維數組，下標範圍分別是整數和小數部分的最小值到最大值。
　　3．再用一個循環把所有源數據填入剛才定義的二維數組，填寫規則是，源數據的
　　整數和小數部分分別對應二維數組的兩個下標。例如，“13.51"填到“A(13,51)"
　　中。
　　4．最後順向或逆向讀取二維數組中的非零數據即可得到從小到大或從大到小排列
　　的數據，而且不會含有重複數據。
　　用VB 編寫的程式如下：
　　'＊＊＊＊密集型數據處理＊＊＊＊
　　Dim i As Long, j As Long, k As Long, kMax As Long
　　Dim Queryp() As Single
　　ReDim Queryp(Amount)
　　Dim IntegerPart As Integer, DecimalPart As Integer
　　Dim IPmax As Integer, IPmin As Integer
　　Dim DPmax As Integer, DPmin As Integer
　　Dim DiffDataArray()
　　'讀取數據
　　ReadData
　　IPmax = 0: IPmin = 1000
　　DPmax = 0: DPmin = 99
　　For i = 1 To Amount
　　' 找整數和小數部分的最大、最小值
　　IntegerPart = Int(sData(i))
　　DecimalPart = (sData(i) － IntegerPart) ＊ 100
　　If IntegerPart > IPmax Then
　　IPmax = IntegerPart
　　ElseIf IntegerPart DPmax Then
　　DPmax = DecimalPart
　　ElseIf DecimalPart 0 Then
　　k = k ＋ 1
　　Queryp(k) = DiffDataArray(i, j)
　　End If
　　Next j
　　Next i
　　kMax = k
　　ReDim Preserve Queryp(kMax)
　　該方法對於本人遇到的這種“密集型”數據最爲有效，但是如果遇上“稀疏型”數
　　據，例如最大、最小值相差幾千，甚至上萬的數據，就沒什麽優勢了，而且會佔用
　　較大的內存。
　　經過改進，我得到了處理稀疏型數據的高效演算法。高效的前提條件同樣是源數據具
　　有大量相同數據。思路是在前一種方法的基礎上增加一個單維數組，用來保存整數
　　部分數據，保存過程中用插入法對其進行排序。因爲有大量重複數據，要排序的數
　　據量相對較少。當從二維數組中讀取數據時，用單維數組代入二維數組的第一個下
　　標，具體代碼下：
　　'＊＊＊＊稀疏型數據處理＊＊＊＊
　　Dim i As Long, j As Long, k As Long, kMax As Long
　　Dim Queryp() As Single
　　ReDim Queryp(Amount)
　　Dim IntegerPart As Integer, DecimalPart As Integer
　　Dim IPmax As Integer, IPmin As Integer
　　Dim DPmax As Integer, DPmin As Integer
　　Dim IPArray() As Integer, IPAamount As Integer
　　ReDim IPArray(Amount)
　　Dim DiffDataArray()
　　'讀取數據
　　ReadData
　　IPmax = 0: IPmin = 1000
　　DPmax = 0: DPmin = 99
　　IPAamount = 0
　　For i = 1 To Amount
　　'獲取整數和小數部分的最大最小值
　　IntegerPart = Int(sData(i))
　　DecimalPart = (sData(i) － IntegerPart) ＊ 100
　　If IntegerPart > IPmax Then
　　IPmax = IntegerPart
　　ElseIf IntegerPart DPmax Then
　　DPmax = DecimalPart
　　ElseIf DecimalPart IPArray(j) Then
　　IPAamount = IPAamount ＋ 1
　　For k = IPAamount To j ＋ 1 Step －1
　　IPArray(k) = IPArray(k － 1)
　　Next k
　　IPArray(j) = IntegerPart
　　Exit For
　　ElseIf IntegerPart = IPArray(j) Then
　　Exit For
　　End If
　　Next j
　　If j > IPAamount Then
　　IPAamount = IPAamount ＋ 1
　　IPArray(IPAamount) = IntegerPart
　　End If
　　Next i
　　ReDim DiffDataArray(IPmin To IPmax, DPmin To DPmax)
　　'填入數據
　　For i = 1 To Amount
　　IntegerPart = Int(sData(i))
　　DecimalPart = (sData(i) － IntegerPart) ＊ 100
　　DiffDataArray(IntegerPart, DecimalPart) = sData(i)
　　Next i
　　'提取數據
　　k = 0
　　For i = 1 To IPAamount
　　For j = DPmax To DPmin Step －1
　　If DiffDataArray(IPArray(i), j) 0 Then
　　k = k ＋ 1
　　Queryp(k) = DiffDataArray(IPArray
　　（i), j)
　　End If
　　Next j
　　Next i
　　kMax = k
　　ReDim Preserve Queryp(kMax)
　　k
　　ReDim Preserve Queryp(kMax)
　　自動隱藏表格中無數據的行
　　表1 是數據源，經常改變；
　　表2 引用表1 中某列有數據的單元格（利用動態位址已實現。）
　　由於表1 的改變，表2 的大小隨之而變。
　　問題：如何實現表2 中沒有數據的行（有公式）自動隱藏？謝謝賜教！
　　Sub abc()
　　For i = 1 To 300
　　If Cells(i, 1).value = "" Then Rows(i).Hidden = True
　　Next i
　　End Sub
　　你寫的語句可以解決隱藏的問題，可是如果我執行了它之後，再在表1中增加數據，
　　表2不會自動顯示有了數據的行。如何修改？
　　將此宏設爲自動運行（打開文件時）
　　Sub abc()
　　For i = 1 To 300
　　If Cells(i, 1).value "" Then Rows(i).Hidden = false
　　Next i
　　End Sub
　　用VBA如何自動合並列的內容？
　　用VBA如何自動合並列的內容？
　　To hongjian ：
　　Sub MergeTest()
　　For i = 3 To 30
　　Cells(i, 3) = Cells(i, 1) & Chr(10) & Cells(i, 2)
　　Next
　　End Sub

Excel VBA 使用函數範例參考之二

2012-08-13T23:39:00.001-07:00

在本示例中，如果活動工作簿不能進行寫保護，那麽 Microsoft Excel 設置字串
　　密碼以作爲活動工作簿的寫密碼。
　　'Sub UseWritePassword()
　　Dim strPassword As String
　　strPassword = "secret"
　　' Set password to a string if allowed.
　　If ActiveWorkbook.WriteReserved = False Then
　　ActiveWorkbook.WritePassword = strPassword
　　End If
　　End Sub
　　在本示例中，Microsoft Excel 打開名爲 Password.xls 的工作簿，設置它的密碼
　　，然後關閉該工作簿。本示例假定名爲 Password.xls 的文件位於 C:\ 驅動器上。
　　'Sub UsePassword()
　　Dim wkbOne As Workbook
　　Set wkbOne = Application.Workbooks.Open("C:\Password.xls")
　　wkbOne.Password = "secret"
　　wkbOne.Close
　　'注意 Password 屬性可讀並返回 “********”。
　　End Sub
　　本示例將 Book1.xls 的當前窗口更改爲顯示公式。
　　Workbooks("BOOK1.XLS").Worksheets("Sheet1").Activate
　　ActiveWindow.DisplayFormulas = True
　　'本示例接受活動工作簿中的所有更改?
　　ActiveWorkbook.AcceptAllChanges
　　本示例顯示活動工作簿的路徑和名稱
　　Sub UseCanonical()
　　MsgBox '訊息方塊
　　[b7] = ActiveWorkbook.FullName '當前工作簿
　　[b8] = ActiveWorkbook.FullNameURLEncoded '活動工作簿
　　End Sub
　　本示例顯示 Microsoft Excel 啓動檔夾的完整路徑。
　　MsgBox Application.StartupPath
　　Activate 事件
　　啟動一個工作簿、工作表、圖表或嵌入圖表時産生此事件。
　　當啟動工作表時，本示例對 A1:A10 區域進行排序。
　　Private Sub Worksheet_Activate()
　　Range("a1:a10").Sort Key1:=Range("a1"), Order:=xlAscending
　　End Sub
　　Calculate 事件
　　對於 Worksheet 對象，在對工作表進行重新計算之後産生此事件
　　每當工作表重新計算時，本示例就調整 A 列到 F 列的寬度。
　　Private Sub Worksheet_Calculate()
　　Columns("A:F").AutoFit
　　End Sub
　　本示例向活動工作簿添加新工作表，並設置該工作表的名稱。
　　Set newSheet = Worksheets.Add
　　newSheet.Name = "current Budget"
　　本示例關閉工作簿 Book1.xls，但不提示用戶保存所作更改。Book1.xls 中的所有
　　更改都不會保存。
　　Application.DisplayAlerts = False
　　Workbooks("BOOK1.XLS").Close
　　Application.DisplayAlerts = True
　　示例顯示每一個可用加載宏的路徑及檔案名。
　　For Each a In AddIns
　　MsgBox a.FullName
　　Next a
　　ChDir 語句
　　改變當前的目錄或文件夾。
　　ChDir path
　　在 Power Macintosh 中，默認驅動器總是改爲在 path 語句中指定的驅動器。完整
　　路徑指定由卷標名開始，相對路徑由冒號 (:) 開始. ChDir 可以辨認路徑中指定的
　　別名:
　　ChDir "MacDrive:Tmp" ' 在 Macintosh 中
　　本示例顯示當前路徑分隔符號。
　　MsgBox "The path separator character is " & _
　　Application.PathSeparator
　　Move 方法
　　將一個指定的檔或檔夾從一個地方移動到另一個地方。
　　語法
　　object.Move destination
　　Move 方法語法有如下幾部分：
　　部分描述
　　object 必需的。始終是一個 File 或 Folder 對象的名字。
　　destination 必需的。文件或文件夾要移動到的目標。不允許有萬用字元。
　　CreateFolder 方法
　　創建一個文件夾。
　　語法
　　object.CreateFolder(foldername)
　　reateFolder 方法有如下幾部分：
　　部分描述
　　object 必需的。始終是一個 FileSystemObject 的名字。
　　foldername 必需的。字串表達式，它標識創建的文件夾。
　　本示例使用 MkDir 語句來創建目錄或檔夾。如果沒有指定驅動器，新目錄或檔
　　夾將會建在當前驅動器中。
　　MkDir "MYDIR" ' 建立新的目錄或檔夾。
　　Name 語句示例
　　本示例使用 Name 語句來更改檔的名稱。示例中假設所有使用到的目錄或檔夾都
　　已存在。在 Macintosh 中，默認驅動器名稱是 “HD” 並且路徑部分由冒號取代
　　反斜線隔開。
　　Dim OldName, NewName
　　OldName = "OLDFILE": NewName = "NEWFILE" ' 定義檔案名。
　　Name OldName As NewName ' 更改檔案名。
　　OldName = "C:\MYDIR\OLDFILE": NewName = "C:\YOURDIR\NEWFILE"
　　Name OldName As NewName ' 更改檔案名，並移動檔。
　　本示例設置替換啓動文件夾。
　　Application.AltStartupPath = "C:\EXCEL\MACROS"
　　FolderExists 方法
　　如果指定的檔夾存在返回 True，不存在返回 False。
　　語法
　　object.FolderExists(folderspec)
　　本示例在單元格中啓用編輯。
　　Application.EditDirectlyInCell = True
　　程式說明：
　　幾種用VBA在單元格輸入數據的方法：
　　Public Sub Writes()
　　1-- 2 方法，最簡單在 "[ ]" 中輸入單元格名稱。
　　1 [A1] = 100 '在 A1 單元格輸入100。
　　2 [A2:A4] = 10 '在 A2:A4 單元格輸入10。
　　3-- 4 方法，採用 Range(" ")， " " 中輸入單元格名稱。
　　3 Range("B1") = 200 '在 B1 單元格輸入200。
　　4 Range("C1:C3") = 300 '在 C1:C3 單元格輸入300。
　　5-- 6 方法，採用 Cells(Row,Column)，Row是單元格行數，Column是單元格欄數。
　　5 Cells(1, 4) = 400 '在 D1 單元格輸入400。
　　6 Range(Cells(1, 5), Cells(5, 5)) = 50 '在 E1:E 5單元格輸入50。
　　End Sub
　　VBALesson3 程式說明：
　　如何利用 Worksheet_SelectionChange 輸入數據的方法。
　　Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　Target = 100
　　End Sub
　　VBALesson4 程式說明：
　　如何利用 Worksheet_SelectionChange 在限定的單元格輸入數據的方法。
　　Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　If Target.Row >= 2 And Target.Column = 2 Then
　　Target = 100
　　End If
　　End Sub
　　VBALesson5 程式說明：
　　比較 Worksheet_SelectionChange() 與用按鈕 CommandButton1_Click() 來執行
　　程式二者的方法與寫法有何不同。
　　Worksheet_SelectionChange()事件
　　Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　If Target.Row >= 2 And Target.Column = 2 Then
　　Target = 100
　　End If
　　End Sub
　　按鈕 CommandButton1_Click()
　　Private Sub CommandButton1_Click()
　　If ActiveCell.Row >= 2 And ActiveCell.Column >= 3 Then
　　ActiveCell = 100
　　End If
　　End Sub
　　二者執行方法最大的地方，在於 Worksheet_SelectionChange() 是自動的，你不用
　　瞭解他是怎麽完成工作的。
　　按鈕 CommandButton1_Click() 是人工的，比 SelectionChange()多一道手續，
　　就是要去按那接鈕，程式才會執行。
　　SelectionChange() 有一個參數 Target 可用；CommandButton1_Click ()沒有。
　　所以我們要用 ActiveCell 內定函數來取代Target，ActiveCell 與 Target最大的
　　不同點他只能指定一個單元格。
　　就是你選取多個單元格也只有最上面的單元格會加上數據；用 Selection 取代
　　ActiveCell，用法就跟 Target 一樣了。
　　VBALesson 6 程式說明：
　　完整的 If...Then ┅ End 邏輯判斷式。
　　Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　If Target.Row >= 2 And Target.Column = 2 Then
　　Target = 200
　　ElseIf Target.Row >= 2 And Target.Column = 3 Then
　　Target = 300
　　ElseIf Target.Row >= 2 And Target.Column = 2 Then
　　Target = 400
　　Else
　　Target = 500
　　End If
　　End Sub
　　這是個完整的 If 邏輯判斷式，意思是說，假如 If 後的判斷式條件成立的話，就
　　執行第二條程式，否則假如 ElseIf 後的判斷式條件成立的話，就執行第四條程式
　　，否則假如另一個 ElseIf 後的判斷式條件成立的話，就執行第六條程式。
　　Else 的意思是說，假如以上條件都不成立的話，就執行第八條程式。
　　他的執行方式是假如 IF 的條件成立的話，就不執行其它ElseIf 及Else 的邏輯判
　　斷式，假如 If 後的條件不成立的話才會執行 ElseIf 或 Else 邏輯判斷式。第二
　　個 ElseIf後的條件因爲與 IF 後的條件一樣，所以這個判斷式後面的 Target=400
　　將是永遠無法執行到的程式。
　　VBALesson 7 程式說明∶我們爲什麽要用變數。
　　Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　Dim i , j As Integer
　　Dim k As Range
　　i = Target.Row
　　j = Target.Column
　　Set k = Target
　　If i >= 2 And j = 2 Then
　　k = 200
　　ElseIf i >= 2 And j = 3 Then
　　k = 300
　　ElseIf i >= 2 And j = 4 Then
　　k = 400
　　Else
　　k = 500
　　End If
　　End Sub
　　Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim iRow, iCol As Integer
　　iRow = Target.Row
　　iCol = Target.Column
　　If iRow >= 2 And iCol = 2 And Target "" Then
　　Application.EnableEvents = False
　　Cells(iRow, iCol + 1) = Cells(iRow, iCol) * 2
　　Application.EnableEvents = True
　　ElseIf iRow >= 2 And iCol = 2 And Target = "" Then
　　Cells(iRow, iCol + 1) = ""
　　Else
　　Cells(iRow, iCol + 1) = ""
　　End If
　　End Sub
　　前幾個教程都是用Worksheet_SelectionChange 事件來舉例子，大家應該能體會他
　　是怎厶一回事了吧。
　　這個教程就是要讓你來體會什厶是Worksheet_Chang()事件。因爲這二個事件在VBA
　　都是非常有用的，所以一定要瞭解。
　　簡單的說，前者是你鼠標移動到那個單元格，就觸發那個事件的執行。後者是要等到
　　你點選的單元格，數?有了改變才會觸發事件的執行。二者執行的時機一前一後。
　　Target "" 是代表限定當前的單元格要是有數?的，才會執行以下三行的程式。
　　Cells(iRow, iCol + 1) = Cells(iRow, iCol) * 2，是你在 B 欄輸入數?時，C
　　欄將可得到 B 欄二倍的數?。
　　Target = "" 是限定當前的單元格要是沒有數?的，才會執行以下一行的程式。
　　Cells(iRow, iCol + 1) = ""，是把 C 欄的數?清成空格。
　　Application.EnableEvents = False與Application.EnableEvents = True，這是
　　個成雙的程式，當你用了前者記得在執行其他程式後要寫上後面的程式。它的目的在
　　抑制事件連鎖執行。簡單的說就是，在 B 欄位所觸發的事件，不願在其它單元格再
　　觸發另一個Worksheet_Change()事件。

Excel VBA 使用函數範例參考之一

2012-08-13T23:38:00.001-07:00

本示例爲設置工作表密碼
　　ActiveSheet.Protect Password:=641112 ' 保護工作表並設置密碼
　　ActiveSheet.Unprotect Password:=641112 '撤銷工作表保護並取消密碼
　　'本示例保存當前活動工作簿的副本。
　　ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS"
　　'本示例通過將 Saved 屬性設爲 True 來關閉包含本段代碼的工作簿，並放棄對該
　　工作簿的任何更改。
　　ThisWorkbook.Saved = True
　　ThisWorkbook.Close
　　'本示例對自動重新計算功能進行設置，使 Microsoft Excel 不對第一張工作表自
　　動進行重新計算。
　　Worksheets(1).EnableCalculation = False
　　'下述過程打開 C 盤上名爲 MyFolder 的文件夾中的 MyBook.xls 工作簿。
　　Workbooks.Open ("C:\MyFolder\MyBook.xls")
　　'本示例顯示活動工作簿中工作表 sheet1 上單元格 A1 中的值。
　　MsgBox Worksheets("Sheet1").Range("A1").Value
　　本示例顯示活動工作簿中每個工作表的名稱
　　For Each ws In Worksheets
　　MsgBox ws.Name
　　Next ws
　　本示例向活動工作簿添加新工作表 , 並設置該工作表的名稱?
　　Set NewSheet = Worksheets.Add
　　NewSheet.Name = "current Budget"
　　本示例將新建的工作表移到工作簿的末尾
　　'Private Sub Workbook_NewSheet(ByVal Sh As Object)
　　Sh.Move After:=Sheets(Sheets.Count)
　　End Sub
　　本示例將新建工作表移到工作簿的末尾
　　'Private Sub App_WorkbookNewSheet(ByVal Wb As Workbook, _
　　ByVal Sh As Object)
　　Sh.Move After:=Wb.Sheets(Wb.Sheets.Count)
　　End Sub
　　本示例新建一張工作表，然後在第一列中列出活動工作簿中的所有工作表的名稱。
　　Set NewSheet = Sheets.Add(Type:=xlWorksheet)
　　For i = 1 To Sheets.Count
　　NewSheet.Cells(i, 1).Value = Sheets(i).Name
　　Next i
　　本示例將第十行移到窗口的最上面?
　　Worksheets("Sheet1").Activate
　　ActiveWindow.ScrollRow = 10
　　當計算工作簿中的任何工作表時，本示例對第一張工作表的 A1:A100 區域進行排序
　　。
　　'Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
　　With Worksheets(1)
　　.Range("a1:a100").Sort Key1:=.Range("a1")
　　End With
　　End Sub
　　本示例顯示工作表 Sheet1 的列印預覽。
　　Worksheets("Sheet1").PrintPreview
　　本示例保存當前活動工作簿?
　　ActiveWorkbook.Save
　　本示例保存所有打開的工作簿，然後關閉 Microsoft Excel。
　　For Each w In Application.Workbooks
　　w.Save
　　Next w
　　Application.Quit
　　下例在活動工作簿的第一張工作表前面添加兩張新的工作表?
　　Worksheets.Add Count:=2, Before:=Sheets(1)
　　本示例設置 15 秒後運行 my_Procedure 過程，從現在開始計時。
　　Application.OnTime Now + TimeValue("00:00:15"), "my_Procedure"
　　本示例設置 my_Procedure 在下午 5 點開始運行。
　　Application.OnTime TimeValue("17:00:00"), "my_Procedure"
　　本示例撤銷前一個示例對 OnTime 的設置。
　　Application.OnTime EarliestTime:=TimeValue("17:00:00"), _
　　Procedure:="my_Procedure", Schedule:=False
　　每當工作表重新計算時，本示例就調整 A 列到 F 列的寬度。
　　'Private Sub Worksheet_Calculate()
　　Columns("A:F").AutoFit
　　End Sub
　　本示例使活動工作簿中的計算僅使用顯示的數字精度。
　　ActiveWorkbook.PrecisionAsDisplayed = True
　　本示例將工作表 Sheet1 上的 A1:G37 區域剪下，並放入剪貼板。
　　Worksheets("Sheet1").Range("A1:G37").Cut
　　Calculate 方法
　　計算所有打開的工作簿、工作簿中的一張特定的工作表或者工作表中指定區域的單元
　　格，如下表所示：
　　'要計算 '依照本示例
　　所有打開的工作簿 ' Application.Calculate （或只是 Calculate
　　）
　　指定工作表 '計算指定工作表Sheet1 Worksheets
　　("Sheet1").Calculate
　　指定區域 'Worksheets(1).Rows(2).Calculate
　　本示例對自動重新計算功能進行設置，使 Microsoft Excel 不對第一張工作表自動
　　進行重新計算。
　　Worksheets(1).EnableCalculation = False
　　本示例計算 Sheet1 已用區域中 A 列、B 列和 C 列的公式。
　　Worksheets("Sheet1").UsedRange.Columns("A:C").Calculate
　　本示例更新當前活動工作簿中的所有鏈接?
　　ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
　　本示例設置第一張工作表的滾動區域?
　　Worksheets(1).ScrollArea = "a1:f10"
　　本示例新建一個工作簿，提示用戶輸入檔案名，然後保存該工作簿。
　　Set NewBook = Workbooks.Add
　　Do
　　fName = Application.GetSaveAsFilename
　　Loop Until fName False
　　NewBook.SaveAs Filename:=fName
　　本示例打開 Analysis.xls 工作簿，然後運行 Auto_Open 宏。
　　Workbooks.Open "ANALYSIS.XLS"
　　ActiveWorkbook.RunAutoMacros xlAutoOpen
　　本示例對活動工作簿運行 Auto_Close 宏，然後關閉該工作簿。
　　With ActiveWorkbook
　　.RunAutoMacros xlAutoClose
　　.Close
　　End With
　　在本示例中，Microsoft Excel 向用戶顯示活動工作簿的路徑和檔案名稱。
　　'Sub UseCanonical()
　　Display the full path to user.
　　MsgBox ActiveWorkbook.FullNameURLEncoded
　　End Sub
　　本示例顯示當前工作簿的路徑及檔案名（假定尚未保存此工作簿）。
　　MsgBox ActiveWorkbook.FullName
　　本示例關閉 Book1.xls，並放棄所有對此工作簿的更改。
　　Workbooks("BOOK1.XLS").Close SaveChanges:=False
　　本示例關閉所有打開的工作簿。如果某個打開的工作簿有改變，Microsoft Excel
　　將顯示詢問是否保存更改的對話框和相應提示。
　　Workbooks.Close
　　本示例在列印之前對當前活動工作簿的所有工作表重新計算?
　　'Private Sub Workbook_BeforePrint(Cancel As Boolean)
　　For Each wk In Worksheets
　　wk.Calculate
　　Next
　　End Sub
　　本示例對查詢表一中的第一列數據進行彙總，並在數據區域下方顯示第一列數據的總
　　和。
　　Set c1 = Sheets("sheet1").QueryTables(1).ResultRange.Columns(1)
　　c1.Name = "Column1"
　　c1.End(xlDown).Offset(2, 0).Formula = "=sum(Column1)"
　　本示例取消活動工作簿中的所有更改?
　　ActiveWorkbook.RejectAllChanges
　　本示例在商業問題中使用規劃求解函數，以使總利潤達到最大值。SolverSave 函數
　　將當前問題保存到活動工作表上的某一區域。
　　Worksheets("Sheet1").Activate
　　SolverReset
　　SolverOptions Precision:=0.001
　　SolverOK SetCell:=Range("TotalProfit"), _
　　MaxMinVal:=1, _
　　ByChange:=Range("C4:E6")
　　SolverAdd CellRef:=Range("F4:F6"), _
　　Relation:=1, _
　　FormulaText:=100
　　SolverAdd CellRef:=Range("C4:E6"), _
　　Relation:=3, _
　　FormulaText:=0
　　SolverAdd CellRef:=Range("C4:E6"), _
　　Relation:=4
　　SolverSolve UserFinish:=False
　　SolverSave SaveArea:=Range("A33")
　　本示例隱藏 Chart1、Chart3 和 Chart5。
　　Charts(Array("Chart1", "Chart3", "Chart5")).Visible = False
　　當啟動工作表時，本示例對 A1:A10 區域進行排序。
　　'Private Sub Worksheet_Activate()
　　Range("a1:a10").Sort Key1:=Range("a1"), Order:=xlAscending
　　End Sub
　　本示例更改 Microsoft Excel 鏈接。
　　ActiveWorkbook.ChangeLink "c:\excel\book1.xls", _
　　"c:\excel\book2.xls", xlExcelLinks
　　本示例啓用受保護的工作表上的自動篩選箭頭?
　　ActiveSheet.EnableAutoFilter = True
　　ActiveSheet.Protect contents:=True, userInterfaceOnly:=True
　　本示例將活動工作簿設爲只讀?
　　ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly
　　本示例使共用活頁簿每三分鍾自動更新一次?
　　ActiveWorkbook.AutoUpdateFrequency = 3
　　下述 Sub 過程清除活動工作簿中 Sheet1 上的所有單元格的內容。
　　'Sub ClearSheet()
　　Worksheets("Sheet1").Cells.ClearContents
　　End Sub
　　本示例對所有工作簿都關閉滾動條?
　　Application.DisplayScrollBars = False
　　如果具有密碼保護的工作簿的檔屬性沒有加密，則本示例設置指定工作簿的密碼加
　　密選項。
　　'Sub SetPasswordOptions()
　　With ActiveWorkbook
　　If .PasswordEncryptionProvider "Microsoft RSA SChannel
　　Cryptographic Provider" Then
　　.SetPasswordEncryptionOptions _
　　PasswordEncryptionProvider:="Microsoft RSA SChannel
　　Cryptographic Provider", _
　　PasswordEncryptionAlgorithm:="RC4", _
　　PasswordEncryptionKeyLength:=56, _
　　PasswordEncryptionFileProperties:=True
　　End If
　　End With
　　End Sub

HTC Home 繁中免安裝版(在電腦桌面顯示 HTC 手機的天氣+翻頁時鐘)

2012-08-13T23:12:00.000-07:00

【軟體名稱】：HTC Home v.2.4 繁中免安裝版
【軟體語言】：繁體中文
【檔案格式】：RAR
【檔案大小】：7.81 MB
【放置空間】：BDG
【有效日期】：(30天無人下載)直到掛點為止～若失連砍檔即視為結束分享,不補檔
【作業系統】：Windows XP/VISTA/7
【軟體說明】：

如果你用的手機是HTC的智慧型手機，想必對於自己手機桌面上的時間及天氣Widget看的已經很習慣，可能還有人看久了回到電腦上不習慣時間在右下角小小的一個，現在也能利用【HTC Home for Windows】這個小工具在電腦桌面製造出一樣的效果，能夠即時顯示時間、天氣及未來天氣預報，提供給大家。

注意事項：需安裝 Microsoft .NET Framework v4.0

【下載網址】：下載後→記得回個帖吧→→讓更多人分享！

這個網頁的指令發生錯誤,必須要有物件VB

2012-08-13T23:08:00.001-07:00

用WebBrowser去開網頁結果開到某些網頁的時候VB都會跳出下面這種狀況

這個網頁的指令碼發生錯誤

行: 5
字元: 1
錯誤: 必須要有物件
程式碼: 0
URL:http://js.wretch.yahoo.net/iframe.php?b=f000&i=5440395&c=1&f=0&e=OC
9mMDAw&h=1701770090...

解決方式:

WebBrowser1.ScriptErrorsSuppressed = true

MSDN 說明
另一種解決方式: For VB

Public Class EWebBrowser
    Inherits System.Windows.Forms.WebBrowser
    Private Iwb2 As SHDocVw.IWebBrowser2
    Protected Overrides Sub AttachInterfaces(ByVal nativeActiveXObject As Object)
        Iwb2 = DirectCast(nativeActiveXObject, SHDocVw.IWebBrowser2)
        Iwb2.Silent = True
        MyBase.AttachInterfaces(nativeActiveXObject)
    End Sub
    Protected Overrides Sub DetachInterfaces()
        Iwb2 = Nothing
        MyBase.DetachInterfaces()
    End Sub
End Class

使用時直接宣告:
Dim Wbrowse As New EWebBrowser()

不要忘記了
Add References -> c:\windows\system32\shdocvw.dll

C# 寫法

class EWebBrowser : System.Windows.Forms.WebBrowser
    {
        SHDocVw.IWebBrowser2 Iwb2;

        protected override void AttachInterfaces(object nativeActiveXObject)
        {
            Iwb2 = (SHDocVw.IWebBrowser2)nativeActiveXObject;
            Iwb2.Silent = true;
            base.AttachInterfaces(nativeActiveXObject);
        }

        protected override void DetachInterfaces()
        {
            Iwb2 = null;
            base.DetachInterfaces();
        }

    }

不要忘記了

Add References -> c:\windows\system32\shdocvw.dll

智慧選股-台股

2012-08-13T23:03:00.001-07:00

技術面選股>>指標趨勢．價量關係

．均線黃金交叉	．3日波段漲跌	．3日波段漲跌幅	．KD黃金交叉	．KD死亡交叉
．均線死亡交叉	．5日波段漲跌	．5日波段漲跌幅	．MACD黃金交叉	．MACD死亡交叉
．均線反轉向上	．20日波段漲跌	．20日波段漲跌幅	．均線反轉向下
．RSI黃金交叉	．60日波段漲跌	．60日波段漲跌幅	．RSI死亡交叉

快速選股
漲幅排行

跌幅排行

成交量排行

成交值排行

外資買賣超排行

投信買賣超排行

自營商買賣超排行

主力買賣超排行

資券變化排行

選股學院--選股策略的哲學
市場面選股	基本面選股	技術面選股	籌碼面選股	財務面選股
股價	成立時間	RSI	融資融券	存貨與應收帳款
漲跌幅度	EPS	KD	外資	資產報酬率
成交量	本益比	MA	自營商	股東權益報酬率
主力買賣超	營收	MTM	投信	毛利率
貝他值	淨值	MACD	集保庫存	營業利益率
	總市值	寶塔線	董監持股比例	負債比率
	股本

短線做多型中線做多型長線做多型短線做空型中線做空型長線做空型

Ｋ線指標

排行項目

類股

上市

上櫃

漲幅排行

電子類股

符合家數:43

符合家數:0

金融證券

符合家數:0

其他類股

符合家數:7

符合家數:35

跌幅排行

電子類股

符合家數:0

金融證券

符合家數:0

其他類股

符合家數:0

符合家數:1

漲停表

跌停表

電子類股

符合家數:0

金融證券

符合家數:0

其他類股

符合家數:0

符合家數:2

均線指標
排行項目	類股	上市	上櫃
量大排行	電子類股	符合家數:100	符合家數:0
	金融證券	符合家數:5	符合家數:3
	其他類股	符合家數:100	符合家數:100
量增排行	電子類股	符合家數:100	符合家數:0
	金融證券	符合家數:5	符合家數:5
	其他類股	符合家數:100	符合家數:100

穿平底鞋血拚腳跟發炎敗興歸

2012-08-13T22:53:00.000-07:00

穿平底鞋血拚腳跟發炎敗興歸

三名貴婦到歐洲血拚，怕穿高跟鞋逛久不舒服，特別改穿平底鞋走路，不料愈走愈痛，結果後腳跟嚴重疼痛，回國就醫才發現穿錯鞋。

澄清醫院中港院區復健治療部主任蔡永裕說，穿平底鞋走太多路，會造成腳跟反覆壓力，使後腳跟的阿基氏腱被反覆性拉長，導致肌腱發炎。穿一公分到一點五公分高的有跟鞋子，比較好走路。

這三名貴婦兩個月前到歐洲深度旅遊，為方便購物，三人捨棄穿久會痛的高跟鞋、不好搭衣服的運動鞋，改穿美美的平底包鞋，認為這樣走路既平穩又輕鬆，有人還在鞋內加超軟鞋墊。

沒想到歐洲之旅走沒幾天，三人腳後跟出現疼痛感，後來一走路就痛，血拚心情全沒了。回國一下機就往醫院跑，經足部超音波檢查，發現是阿基氏腱嚴重發炎。

蔡永裕說，一般人走路都是腳跟先著地，腳跟會產生體重三到四倍壓力，尤其穿平底鞋走路，會造成腳跟反覆壓力，使後腳跟的阿基氏腱因反覆性拉長發炎。

蔡永裕指出，體重愈重，腳跟的壓力也愈大，跟腱受傷機率相對較高。

另外鞋內加軟鞋墊，會造成腳跟陷下去，不但會無法吸收腳跟壓力，反而拉長阿基氏腱，比沒加鞋墊還嚴重。

台中市鞋類暨運動休閒科技研發中心鞋面技師紀月麗建議，買鞋時最好試穿多走幾次，了解高度、鞋墊是否適合，以及腳跟、足弓和腳掌支撐度是否足夠。

腳掌寬者宜挑寬楦頭，另外腳背有肉者，鞋面高度不能太高，以免肉擠在鞋面外，造成腳掌壓力。

生命靈數DNA數字解析法

2012-08-13T21:52:00.000-07:00

【天劫．風】的藏劍閣

生命靈數 DNA 數字解析法
資料來源:陽光下的百合

與生俱來的數字：
身分證號碼、出生年月日、姓名等等
後天形成的數字：
電話號碼、車牌、地址、信用卡號碼、房間號碼等等

解碼對照表：

=======================
伏延生天禍六絕五
位年氣醫害煞命鬼
=======================
11 19 14 13 17 16 12 18
22 26 28 27 23 29 21 24
33 34 39 31 32 38 37 36
44 43 41 49 46 47 48 42
66 62 67 68 64 61 69 63
77 78 76 72 71 74 73 79
88 87 82 86 89 83 84 81
99 91 93 94 98 92 96 97
=======================

身分證字母對照表：

=====================
|0 1 2 3 4 5 6 7 8 9
-+-------------------
0| A B C D E F G H I
1|J K L M N O P Q R S
2|T U V W X Y Z
=====================
上述對照表字面意義，借用自古老的易經，詳細涵義如下：
＊伏位：等待、臥虎藏龍、蓄勢待發等意義
＊延年：生命力強、獨當一面、綿綿不斷等意義
＊生氣：新的轉機、貴人相助、豁然開朗等意義
＊天醫：代表財富、與生俱來的智慧等意義
＊禍害：常受身體病痛所擾、或常有口舌之爭等意義
＊六煞：人際關係不佳、感情不順利等意義
＊絕命：起伏波動大、非富即貧、常有意外或官司糾紛等意義
＊五鬼：特立獨行、難以捉摸、不循正軌等意義

「0」的意義：
在頭跟尾出現，視為伏位。Ex: 0249->22 24 49 9420->94 42 22
在中間出現、視為伏位。Ex: 26049->26 66 44 49

「5」的意義： 在頭跟尾出現，視為伏位。5249->22 24 49 9425->94 42 22
在中間出現則跳過。26549->26 64 49
在9與1或1與9之間視為重複一次。951->91 19 91

身份證字號：
1、第一個英文A＝01，B＝02依此類推。
2、算命格時，第一個0要忽略，算人生際遇時，要算進來。
3、人生際遇階段分為
0~13歲 13~18歲 18~23歲 23~28歲 28~33歲
33~38歲 38~43歲 43~48歲 48~53歲 53~58歲 ...

想改變先天的缺憾，在後天的生活中作改變：
1、天醫欺絕命
2、延年壓六煞
3、（生氣+天醫+延年）化五鬼，順序不能變動
4、（生氣+延年）或（生氣+伏位）或（生氣+生氣）化禍害
車牌範例：
五鬼車牌，車主喜蛇行，易有血光之災，易被破壞。
絕命車牌，車主喜直線，會有意外發生。
六煞車牌，已婚者易與家人衝突，未婚者多半在車內與自己人爭吵
禍害車牌，不分親疏，易與他人發生口角
伏位車牌，如果車主是伏位命格，又用伏位車牌，往往是事業或戀情停滯不前。
延年車牌，事業及生活順利。
好車牌有以下六種最好選擇：
生氣+延年+延年天醫+延年+天醫
生氣+延年+天醫天醫+天醫+延年
天醫+生氣+生氣天醫+天醫+天醫
六煞+絕命或五鬼會使傷亡更慘重
數字解析法具有以下特點：
先天磁場與後天磁場是可相互印證
操作容易
創造後天磁場，獲得運勢上的改變
生命中重大事件的時間，可以很準確的展現
不必在意本命磁場，起跑點不同
創業分析：
天醫型的適合各行各業
伏位型的適合小本經營
絕命型的適合創意型的
五鬼型的適合特種行業
是否能為公司創造業績分析：
天醫型：頂尖業務
生氣型：業績重要指標
延年+生氣：常有佳作
延年+天醫：常有驚人表現
伏位+天醫：慢工出細活
絕命+天醫：首席智囊團
（2天醫+生氣）或（2天醫+延年）或（2生氣+2延年）：靈魂人物或領袖

首先，把你要算的號碼拆解：

例如：0933894637→09、93、33、38、89、94、46、63、37

拆解完再查特性總覽表

◎而特殊用法是遇0則改成與另一個數字相同，前例的09→99

◎另外5在數字的頭或尾也改成與另一個數字相同

如5123則51→11；6485則85→88

如果5在數字中間不管有幾個5都去掉

如12567→1267→12、26、67

◎最棒的5，在1和9中間時

如49513→去掉5→重覆一次91→491913

如81597→去掉5→重覆一次19→819197

這樣會了嗎??你也可以算英文名字、車牌，英文字母A就是1，依此類推

中文名字就用筆劃來算就可以了

天醫	【13】【27】【49】【68】….【31】【72】【94】【86】
	大財、神來之筆、天生聰穎、當老闆。
生氣	【14】【28】【39】【67】….【41】【82】【93】【76】
	新的轉機、起死回生、有貴人、智慧、豁然開朗、EQ高、彈性大。
延年	【19】【26】【34】【78】….【91】【62】【43】【87】
	獨當一面、生命力意志力極強、綿綿不絶、大將之風、大男(女)人主義、領導者。
伏位	【11】【22】【33】【44】【66】【77】【88】【99】
	等待、蓄勢待發、臥虎藏龍、篡位、狀況延續。
六煞	【16】【29】【38】【47】….【61】【92】【83】【74】
	人際感情婚姻之路不順、猶豫不決、判斷錯誤、桃花八卦指數高、與異性密友糾葛多。
禍害	【17】【23】【46】【89】….【71】【32】【64】【98】
	身體病痛、口舌是非、易逞強愛面子、口才好、衝動心計深。
絶命	【12】【37】【48】【69】….【21】【73】【84】【96】
	起伏波動大、非富即貧兩極化、才華出眾、超級軍師、善謀略心思敏捷、常有意外出現，易碰上官司糾紛、際遇波折。
五鬼	【18】【24】【36】【79】….【81】【42】【63】【97】
	陰柔、不尋正軌、最極端、難以捉摸、命運變化大、常主動造成分離、易成第三者、有鬼才。

四吉者：延年〔為財庫〕
       生氣〔為事業、生育〕
       天醫〔代表健康、文昌位〕
       伏位〔一切好的總合〕

四凶者：六煞〔外遇、桃花〕
       絕命〔多生女〕
       五鬼〔是非、口舌、官司、小偷、火災、鬧鬼〕
       禍害〔意外凶災〕

排完再對照上面的號碼就可以知道自己的大概運勢摟!!!!! 好玩一下
天醫: 13 27 49 68 31 72 94 86    天生命好。
生氣: 14 28 39 67 41 82 93 76    貴人多。
延年: 19 26 34 78 91 62 43 87    老闆，領袖級，會有大男人或大女人主義。
五鬼: 18 24 36 79 81 42 63 97    搬財。
(有一個五鬼適合做業務!!! 因為可以把別人的才搬過來，但有兩個以上就會亂花錢)
六煞:16 29 38 47 61 92 83 74    代表人緣，但是太多的話感情會不穩
(有一個五鬼跟一個六煞最適合做業務)
禍害: 17 23 46 89 71 32 64 98    比較或給人找麻煩。
絕命: 12 37 48 69 21 73 84 96 宗教信仰，適合當算命師
(太多時表示一輩子比較起伏不定，官司多)
伏位: 11 22 33 44 55 66 77 88 99 懶惰,
(要把手機改成有生氣的號碼就可以擋掉一些啦)
車牌
五鬼:血光，偷竊，破壞
絕命:擦撞，意外
六煞:在車內跟自家人吵架
禍害:吵，不管跟人都吵
伏位:感情事業停滯不前

磁場化解......
伏位
增加生氣＋天醫＋延年，能夠啟動伏位的能量

天醫
增加生氣＋延年，是讓它好上加好的能量

生氣
增加延年＋天醫，是完美的最佳組合

延年
增加生氣＋天醫，是最有力量的組合狀態

六煞
增加延年，才能壓制負面能量帶動正面能量

絕命
增加天醫，才能破解負面能量帶動正面能量

禍害
增加生氣與生氣、生氣與延年、生氣與伏位，（順序可變）才能化解負面能量帶動正面能量

五鬼
同時具有生氣、天醫、延年（順序不可錯）才能化解負面能量帶動正面能量更多

影片參考

雲端資料庫

全區目錄

Excel VBA 使用函數範例參考之六

Excel VBA 使用函數範例參考之五

Excel VBA 使用函數範例參考之四

Excel VBA 使用函數範例參考之三

Excel VBA 使用函數範例參考之二

Excel VBA 使用函數範例參考之一

HTC Home 繁中免安裝版(在電腦桌面顯示 HTC 手機的天氣+翻頁時鐘)

這個網頁的指令發生錯誤,必須要有物件VB

智慧選股-台股

穿平底鞋血拚 腳跟發炎敗興歸

穿平底鞋血拚 腳跟發炎敗興歸

生命靈數DNA數字解析法

穿平底鞋血拚腳跟發炎敗興歸

穿平底鞋血拚腳跟發炎敗興歸