PCMAN: EXCEL VBA

顯示具有 EXCEL VBA 標籤的文章。顯示所有文章

破解excel保護密碼

破解excel保護密碼

<<資料搜集自網上>>1.到「http://www.straxx.com/excel/password.html」下載「password.xla」這個檔案。

2.打開有保護的Excel文件，在功能表上的【工具】按一下滑鼠左鍵，接著從選單中點選【增益集】。

3.按下「增益集」對話盒中的〔瀏覽〕，接著找到剛才下載的位置，點選「password.xla」後按下〔確定〕。

4.接著會發現選項中多了「Password recover」，勾選之後再按下對話盒中的〔確定〕。

5.出現一個提示訊息對話盒，沒關係，直接在〔確定〕上按一下滑鼠左鍵繼續下一個步驟。

6.破解保護 - 點選左下角要破解的〔Sheet〕後，按下功能表中的【工具】，接著從選單中點選【Unprotect sheet】，以去除工作表的保護！

7.解除保護了！破解使用時間會按密碼的複雜程度而有所不同，但還是遠比「暴力破解法」來得快，按下〔確定〕就可以繼續編輯文件。

新增欄位後跳出"偵錯"視窗的原因?

我在新增欄位的時候(黃色部分)~跳出

執行階段錯誤'13':
型態不符合

雖然我都直接按"結束" 是沒有發生什麼問題，也可以新增，但還是想了解一下是哪裡出了問題。
回覆：
直接按結束你的事件就無法在驅動了

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [$E$12:$E$65536]) Is Nothing Then Exit Sub 'e欄小寫轉大寫
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
Target = UCase(Target)
Application.EnableEvents = True
End Sub

***
是插入整列所以觸發程序後的Target無法被確認所以跳出錯誤訊息
***
原來如此沒有看清楚題意.謝謝指點
你加上 If Target.Count > 1 Then Exit Sub 來化解樓主問題
我將 Target 指定為第一個Cell 就沒問題了

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target.Cells(1), [$E$12:$E$65536]) Is Nothing Then Exit Sub 'e欄小寫轉大寫
Application.EnableEvents = False
Target.Cells(1) = UCase(Target.Cells(1))
Application.EnableEvents = True
End Sub

"Dim i%"的意思呢?為什麼會用%和不用 as....... 呢?

可以教我一下"Dim i%"的意思呢?為什麼會用%和不用 as....... 呢?
Dim i% 我也看不懂，是Row 與Column 需宣告為？
看不懂，好奇測試一下
將那個刪掉測試結果相同
不管這對於結果有沒有影響，倒是挺好奇Dim i% 是否另有含意或特殊用法
網上答案：

Dim i%就是Dim i As Integer的簡寫
一些常用的代表符號如下
Integer 的型態宣告字元是百分比符號 %
Long 的型態宣告字元為 &
Double 的型態宣告字元是數字符號 #
Single 的型態宣告字元為 !
String 的型態宣告字元為 $

使用ActiveX Button執行程式碼，Range("A1").Select無法正常執行

使用ActiveX Button執行程式碼，Range("A1").Select無法正常執行，程式碼如下：

Private Sub CommandButton1_Click()
Sheets("第二個").Select '--->這一段可以正常執行
Range("A1").Select '--->這一段會無法正常執行，且會出現錯誤訊息，如下圖所示。
End Sub

網上答案
CommandButton1_Click 是工作表1的程序 Range("A1").Select  是指在工作表1的 .Select
Sheets("第二個").Select 後作用中的工作表是工作表2 所以會錯誤
Private Sub CommandButton1_Click()
With Sheets("第二個")
  .Select
  .Range("A1").Select
End With
End Sub

我的select case 為什麼執行起來像無窮迴圈??

想寫一個從選單儲存格選取後，依選取的人員各自進行一些處理，但不知為什麼trace時發現case區段內指令會一直重複執行，請教各位，謝謝~

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rowNo, colNo, countNo
Dim thisDate As String
Dim recStr As String
Dim sourceFile, backupFile

colNo = Selection.Columns.Column
rowNo = Selection.Rows.Row

thisDate = Str(Format(DateSerial(Year(Date), Month(Date), Day(Date)), "yyyymmdd"))

SetCurrentDirectoryA "\\econb\fs$\FS"
ChDir ".\資訊系統\系統測試"

If colNo = 2 Then                '如果選定測試人員(B)欄位

      Select Case Selection.Value

         Case "胡先生"

            countNo = Application.WorksheetFunction.CountIf([B1:B300], "胡先生")
            recStr = "H-" + thisDate + "-" + Str(countNo)
            Call genRecFile("胡先生", recStr, rowNo, colNo)
            Call callWord("胡先生", recStr)

         Case "王小姐"
            countNo = Application.WorksheetFunction.CountIf([B1:B300], "王小姐")
            recStr = "W-" + thisDate + "-" + Str(countNo)
            Call genRecFile("王小姐", recStr, rowNo, colNo)
            Call callWord("王小姐", recStr)
         Case "黃小姐"
            countNo = Application.WorksheetFunction.CountIf([B1:B300], "黃小姐")
            recStr = "F-" + thisDate + "-" + Str(countNo)
            Call genRecFile("黃小姐", recStr, rowNo, colNo)
               Call callWord("黃小姐", recStr)
         Case Else


      End Select
End If
'---------------------------------------------------------------------------------------------------------------
If colNo = 7 Then                   '如果選定提交廠商欄位
      Dim fileStr As String
         fileStr = Cells(rowNo, colNo - 3).Value ".doc"
      Dim fsApp As Object
         Set fsApp = CreateObject("Scripting.FileSystemObject")
      '
      If Selection.Value = "提交" And Cells(rowNo, colNo - 3).Value <> "" Then       '如果提交且紀錄編號不等於空白
         '
         fsApp.Movefile ".\測試報告\" fileStr, ".\待提交\"                                     '將word測試檔移到待提交目錄
         '
         Selection.Value = Selection.Value + "(" + thisDate + ")"
         Range(Cells(rowNo, colNo - 2), Cells(rowNo, colNo - 2)).Hyperlinks(1).Address = ".\待提交\" + fileStr

      ElseIf Selection.Value = "提交" And Cells(rowNo, colNo - 3).Value = "" Then
         MsgBox "測試報告WORD檔不存在!!"
         Selection.Value = ""
      ElseIf Selection.Value = "取消提交" And Cells(rowNo, colNo - 3).Value = "" Then
         MsgBox "測試報告WORD檔不存在!!"
         Selection.Value = ""
      ElseIf Selection.Value = "取消提交" And Cells(rowNo, colNo - 3).Value <> "" Then
         fsApp.Movefile ".\待提交\" fileStr, ".\測試報告\"                                     '將WORD檔移回原目錄
         Range(Cells(rowNo, colNo - 2), Cells(rowNo, colNo - 2)).Hyperlinks(1).Address = ".\測試報告\" + fileStr
      Else


      End If

      Set fsApp = Nothing

End If
End Sub

Sub genRecFile(Name As String, ByVal recStr As String, ByVal rowNo, ByVal colNo)
      Cells(rowNo, colNo + 2) = recStr                                     '記錄編號欄位
      Cells(rowNo, colNo + 3).Select                                     '開啟測試報告欄位

      ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=".\測試報告\系統測試異常報告空白表單.doc" _
                           , TextToDisplay:="開啟"

      sourceFile = ".\測試報告\系統測試異常報告空白表單.doc"
      backupFile = ".\測試報告\" + recStr + ".doc"
      FileCopy sourceFile, backupFile
      Selection.Hyperlinks(1).Address = ".\測試報告\" + recStr + ".doc"                '設定開啟超連結
      Cells(rowNo, colNo + 1).Value = DateSerial(Year(Date), Month(Date), Day(Date))
End Sub

Sub callWord(Name As String, ByVal recStr As String)
         Dim WDAPP As Word.Application
         Set WDAPP = CreateObject("Word.Application")
            'Set WDDOC = GetObject(".\測試報告\" recStr + ".DOC")
         WDAPP.Documents.Open "I:\資訊系統\系統測試\測試報告\" recStr + ".DOC"
         WDAPP.Visible = True
            'Selection.Goto What:=wdGoToBookmark, Name:="recNo"

            'Selection.TypeText Text:=recStr    '在游標處打字
            'Selection.Paste
            ''Selection.TypeParagraph                         '新增一行
            'WDDOC.Save '儲存回原檔案(擇一選用即可)
            ''WDDOC.SaveAs "E:/ANY/COSMOS.DOC" '本行為另存新檔
         WDAPP.Quit '本行為操作完畢自動關掉WORD的功能
         Set WDAPP = Nothing

回覆：
試試
在worksheet_change的最前一行加
Application.EnableEvents = False
和在worksheet_change的最後一行加
application.EnableEvents = true

worksheet_change運行時有東西寫上worksheet,那麼worksheet_change又開始一個新迴圈
回覆：

果真是如此，難怪我一直查閱select case用法，也看不出所以然來

VBA的寫作技巧與增進效能(轉載)

(轉載：將由網上找到的認為有用的東西留起，方便日後自己使用及學習。作者如不滿，請告知，以便刪除不放在網誌上。)
*****************************************************************************************************

VBA的寫作技巧與增進效能

經由錄製產生的巨集，通常程式碼都會含有很多 Select，甚至往後自己寫的程式也習慣用一堆 Select。寫程式的人以為必須 Select 一個物件後才能對它做處理，但這是 [錄製巨集] 誤導的錯誤觀念 (自己也沒有徹底了解語法)，而且是造成巨集執行效率不佳的原因之一。

一、數數看你的程式裡有多少 "Select" ?
除非程式就是要依使用者選取的物件來做動作，否則 Select 和 Selection 都是多餘的.
◎ 標準的物件控制語法：
　物件.方法　（例如 Range("A1").Copy）
　物件.屬性 = 值　（例如 Range("A1").ColorIndex = 15）
而不是一定要先 Select 物件然後再對 Selection 做動作.

舉例而言，你要複製 Sheet1.A1 的值到 Sheet2.B1 --
　Range("A1").Copy
　Sheets(2).Select
　Range("B1").Select
　Range("B1").PasteSpecial xlPasteValues
其實可以這麼寫 --
　Sheets(2).Range("B1") = Sheets(1).Range("A1")
如果內容與格式都要複製，可以這麼寫 --
　Sheets(1).Range("A1").Copy Sheets(2).Range("B1")

不要看這沒什麼，你的VBA觀念和程度能否更進一步，這是很重要的一點。

二、關閉螢幕更新（Application.ScreenUpdating）
程式裡做的動作越多，螢幕更新的問題就越明顯。例如選取了儲存格、選取物件、複製、貼上、切換工作表... Excel 都會改變焦點 (Focus). 每改變一次，就是一次螢幕更新。想想看，在一連串的螢幕更新之中，不但令使用者眼花撩亂，程式執行的整體效能也會下降。

這與減少 Select 是一體兩面的事，其實很多選取儲存格、選取物件、複製、貼上、切換工作表... 的動作都是不必要的。只要技巧用的好，ScreenUpdating 幾乎可以束之高閣。

三、過多/不必要的迴圈也會降低執行效率
迴圈 (如 For...Next、Do...Loop等等) 是很重要的寫作技巧之一，它能大幅簡化程式中重複的動作，而且是錄製不出來的。
這裡所謂不必要的迴圈是指處理的範圍太大，浪費過多時間。例如
For Each cell In Columns(1)
　......
Next
For Each cell In [A1:A65536]
　......
Next
以上兩個迴圈都是處理 A 欄 6 萬多個儲存格。
說實在的，連幾千個Cell我都有點擔心了，何況幾萬個 -- 有必要嗎??
何不判斷好資料的範圍再來做迴圈 --
For Each cell In Range([A1], [A65536].End(xlUp))
　......
Next

參考: 如何判斷資料範圍
http://gb.twbts.com/index.php/topic,315.0.html
http://gb.twbts.com/index.php/topic,584.0.html

四、釋放物件變數佔用的記憶體空間
在這裡尤指對應用程式(Appliation)的引用與存取，下例從Word表格取回資料至Excel工作表 --

Sub get_word_table( )
Dim wrdApp As Object
Set wrdApp = CreateObject("Word.Application") '建立引用Word應用程式的物件
Set wrdDoc = wrdApp.Documents.Open("D:\Temp\ole_test.doc") '引用Word文件
With wrdDoc.Tables(1)
　For r = 1 To .Rows.Count
　　For c = 1 To .Columns.Count
　　Cells(r, c) = .Cell(r, c)
　　Next c
　Next r
End With
wrdDoc.Close 'close the document
wrdApp.Quit 'close Word
Set wrdDoc = Nothing '釋放物件變數
Set wrdApp = Nothing
End Sub

初學者常常會忽略最後兩句，如果不寫雖然不會影響程式的運行，但從記憶體管理和效能控制的角度而言，這是個很不好的習慣。

當省則省，省的是多餘重複的程式碼；
當用則用，用的是不可或缺的程式碼。

請問一下：
　Sheets(2).Range("B1") = Sheets(1).Range("A1")
這種寫法如果要針對某範圍例如從sheet1的A1:a10做陣列轉換到sheet2的a1:j1
要如何編寫程式碼?
***
sheet2.[A1:J1]=application.transpose(sheet1.[A1:A10])
***
一、數數看你的程式裡有多少 "Select" ?
select 真的是不大需要, 我目前已經很少使用了, 大部分用在要取得特定位址, 以作為下一個指令參考之用o

三、過多/不必要的迴圈也會降低執行效率
我以前會用 do while or if 指令來判斷後繼續執行, 後來碰到 i=i+1 時會碰到溢位問題, 後來就改用 find 指令,
我感覺執行速度是快了很多, 這是否比較好?
***
Cells(r, c) = .Cell(r, c)

這行,究竟幾時用單數的物件,例如cell,worksheet等字眼,有單數眾數,比較混亂
***
cells並無所謂擔負數之分，在EXCEL中cells就是全部儲存格，而括號中的2個引數，分別是列號與欄號
Cells(1,1)就是指到A1儲存格，他就是單一儲存格，若CELLS則會指向所有儲存格。
WorkSheet是工作表物件，這唯一會造成單數現象是發生在變數宣告時，當變數要宣告成工作表物件型態時
Dim Sh As WorkSheet
這就表示Sh變數是一個工作表
那麼，當我們在眾多工作表中，取得單一工作表就是在複數工作表中指名工作表
Set Sh=WorkSheets(index)
***
在EXCEL2003裡寫了如下:
01 Range("D6:E6").Copy
02 Range("h3").PasteSpecial xlPasteValues
因為各有一個值分別在D6&E6, 所以直接複製到H3時, 就會變成複製到H3 & I3

想要依照謝大的方式簡短, 分別試了如下:
Sheet1.[H2:I2] = Application.Transpose(Sheet1.[D6:E6])
結果僅會把D6的值複製到H2&I2, E6並不會複製到I2.

另外也試了:
Range("H2:I2") = Range("D6:E6")
結果都沒有動作.
請問如果要把同一個Sheet的D6 & E6複製到H3 & I3應該如何寫語法呢 ?
***
Range("H2:I2") = Range("D6:E6").Value
***
以下兩個寫法的效果是一樣的:
Range("H2:I2").Value = Range("D6:E6").Value
Range("H2:I2") = Range("D6:E6").Value
****
請教一下，當我的程式需要參考好幾個excel檔案的內容時，我以前的做法就是 worksheets("data.xls")....Range(xxx)這樣取得或更新資料，可是當資料內容龐大時，速度變的好慢好慢，就算是程式內部創造一個陣列把資料先讀進來，也是得面臨那段緩慢的讀取時間。
請問VBA中是不是有甚麼正規做法可以解決大量儲存格資料存取的問題呢？
***
試試下列程式
在開啟的所有活頁簿中,將除了作用中活頁簿 (ActiveWorkbook) , 之外的Sheets(1).UsedRange ,收集到作用中活頁簿中的ActiveSheet

Sub Ex()
Dim Book As Workbook, Rng(1 To 2) As Range
With ActiveWorkbook.ActiveSheet
Set Rng(1) = .Range("A" & Rows.Count).End(xlUp)
For Each Book In Workbooks
If Book.Name <> .Parent.Name Then
Set Rng(2) = Book.Sheets(1).UsedRange
Rng(1).Resize(Rng(2).Rows.Count, Rng(2).Columns.Count) = Rng(2).Value
Set Rng(1) = .Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next
End With
End Sub

****

從此文章學到精華，這些簡化方式在各先進提供解答中
都可以學到，經由此篇更精華吸收，感恩
總是利用巨集錄製，再依學習到的VBA語法
想想怎麼簡化，來到這看看其他人的寫法
再看看以前寫的，總是可以學到一些
像是單純現存數據，以前總是犯了選取cells
再處理，近日學到一些，針對利用處理數據
寫了一段處理格式的語法
目前處理資料尚可，但一直持續學習簡化增進效能技巧中
關於Application.ScreenUpdating 學到，正在運用簡化中
目前正在學習如何簡化，如果有簡化idea 煩請提供供學習，感恩

KRowEnd = Cells(Rows.Count, 1).End(xlUp).Row '以 A欄資料為基礎 =1 判斷範圍
kcolend = Cells(1, Columns.Count).End(xlToLeft).Column '以第一列資料為基礎 =1判斷判斷範圍

MsgBox "列數KRowEnd=" & KRowEnd
MsgBox "欄數kcolend=" & kcolend

Range(Cells(1, 1), Cells(1, kcolend)).Select

With Selection.Interior
      .ColorIndex = 36 '淺黃色
      .Pattern = xlSolid
End With
Selection.Font.ColorIndex = 3

Range(Cells(2, 1), Cells(KRowEnd, kcolend)).Select

ActiveWindow.FreezePanes = True
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
      "=MOD(ROW(),2)"
Selection.FormatConditions(1).Interior.ColorIndex = 15
Range(Cells(1, 1), Cells(1, kcolend)).Select
Selection.AutoFilter
Cells.EntireColumn.AutoFit

迴圈寫法問題

發現以下程式碼有錯。
要如何才能讓D1的值去重複讀取A欄的值往下 ?
例如: A1到A1000
------------------
Sub 迴圈()
'
' 迴圈  Macro

   For Each k In Sheets("sheelt1").Range("a:a")       '迴圈要連續處理處理sheelt1 A欄的儲存格

         Range("D1").Select =k .Value

                           Application.Run Macro:= "A"  '使用原本sheelt1裡的模組A
            Next
End Sub
-------------------
可更改為如下程式碼：-
Sub yy()
For Each c In [a:a].SpecialCells(2)
[d1] = c
Next
End Sub
-----------------
問：
還有一個問題 A模組還是無法執行，請問如何執行A模組？
-----------------
答：
Application.Run Macro:= "sheelt1.A" 使用原本sheelt1裡的巨集名稱A
Application.Run Macro:= "A" 一般模組的巨集名稱A
-----------------
現在又有一個問題了，程式碼如下：
Sub yy()
For Each c In [A:A].SpecialCells(2)
      [D1] = c
               Application.c Now + TimeValue("00:00:30")
   Next
               Application.Run Macro:= "A"
End Sub

D1儲存格因連接到其它的工作表單為動態更新外部資料IQY
從A1讀取儲存格時因會出現一個重複迴圈而沒有停駐使查詢沒有傳回資料
請問如何從A1到D1時停駐一段時間後再去執行A2,A3,A4.............到A?儲存格
可用時間設定讓他去延長等待時間嗎?
----------------
答：
例如延10秒：Application.OnTime Now + TimeSerial(0, 0, 10),"Dosomething"
---------------
我試過
Application.OnTime Now + TimeSerial(0, 0, 10), "Dosomething" '延長等待時間10秒
會顯示無法執行巨集 Excel 會無法關閉必需強制關閉
而單獨寫成一個巨集可以執行

試過在迴圈裡讀取此巨集但D1裡資料會停在A1儲存格  不用強制關閉excel
Application.Run Macro:= "A" 也沒有動作
也不會繼續往下讀取A欄裡的A2,A3,A4.............到A?儲存格
=================================================================
巨集裡的

Sub Time()
Application.OnTime Now + TimeSerial(0, 0, 10), " yy"
End Sub

複製代碼

=================================================================
迴圈裡的

Sub yy()
For Each c In [A:A].SpecialCells(2)
[D1] = c
If c = "" Then Exit For
Application.Run Macro:= "Time"
Next
Application.Run Macro:= "A"
End Sub

如何解決？
----------------------------------
試一下以下更改了的程式碼：
Sub yy()
    For Each c In [A:A].SpecialCells(2)
    [D1] = c
    Application.Run Macro:="A"
    t = Timer
    Do
    DoEvents
    Loop Until Timer - t = 2
    Next
End Sub
Sub A()
For i = 1 To 1000
[e1] = i
Next
End Sub
------------------------

遞增排序

遞增排序：
Sub EX()
Application.ScreenUpdating = False
Dim A As Range
For Each A In [A2:A5001]
Range(A.Offset(, 1), A.Offset(, 1).End(xlToRight)).Sort key1:=A.Offset(, 1), Header:=xlNo, Orientation:=xlLeftToRight
Next
Application.ScreenUpdating = True
End Sub

關於For迴圈的使用

Private Sub CommandButton1_Click()
    '複製主檔案
    Range("A1:H44").Select
    Selection.Copy

    '貼上2.3.4...頁面
    Range("A54:D97").Select
    ActiveSheet.Paste
    Range("A107:D150").Select
    ActiveSheet.Paste
    '．
    '．
    '．
    Range("A478:D521").Select
    ActiveSheet.Paste

    '調整列高
    Rows("45:53").Select
    Selection.RowHeight = 16.5

    Rows("98:106").Select
    Selection.RowHeight = 16.5
    '．
    '．
    '．
    Rows("469:477").Select
    Selection.RowHeight = 16.5

End Sub

以上程式運行期間，每次貼都會出現"您要取代目標的儲存格嗎?"

我計算出他們的等差=53

未來我打算利用Textbox填入後執行

有沒有比較快的寫法嗎? 不一定要用For迴圈也可以

迴圈初步概念如下
Dim r1=1 , r2=44
Range("A" r1 & ":H" & "r2").Select
For r1<478 then
r1=r1+53
Next

For r2<521 then
r2=r2+53
Next

不知道對不對?
---------------
答：
語法有誤唷~
FOR的語法應該是下述方式 (從多少到多少)
for i =1 to 100 ...... next

你可以使用Do ....Loop的方式可以上r1與r2累加到滿足妳的條件下離開~
----------------
答：
試一下以下程式碼：
Sub Ex()
    Dim i As Integer
    With ActiveSheet
    .[A1:H44].Copy
    For i = 53 To 477 Step 53
    .Paste Range("a" & i)
    .Rows(i & ":" & i + 43).RowHeight = 16.5
    Next
    End With
    Application.CutCopyMode = False
End Sub
-----------

IF不可不用,不可多用

IF不可不用,不可多用

文章选自:http://post.baidu.com/f?kz=49511214,作者:juyouhh
            先说不可不用。
         if最善于解决非此即彼、非男即女、非阴即阳、非前即后、非有即无的问题。如果问题的答案是二选其一，则除了if，没有更好的办法。比如学龄，以7岁为条件，if(年龄>=7,"已到学龄","未到学龄")，做这样的判断，任何函数方法都不会更简明于此了。
         如果我们的问题都是这么简单就好了。
         有一个著名的数组公式，其内核公式为：if(match(列起点:列终点,列起点:列终点,0)=row(列起点:列终点),row(列起点:列终点),"")，作用是在一列中查找重复值各单项的所在行号，这个if就是不可或缺，不可不用的，因为到目前为止还没有其他更简明的办法来达到用公式筛选重复值的目的。但说穿了，if在这里所解决的，仍然还是一个非此即彼的问题。
         再看一例：设A列为姓名，B列为数值，求姓名甲的数值合计。{=SUM(IF(A1:A15="甲",B1:B15))}，其实也是一类问题，是{=SUM(IF(A1:A15=" 甲",B1:B15,0))}的一种简写，叫做非甲即0。而在数组公式中，*号可以用来替代AND，+号则可以替代OR，因此也可以进一步简写作 {=SUM((A1:A15=F1)*B1:B15)}，而且条件越多，越可以体现这种写法的优点，比如再加上一列月份，求甲在3月份的数值合计，你可以省下两个if，多用一个*号就可以了（自己试试？）
   再来说不可多用。
         为什么不可多用？大致是因为：一、会增加公式写入的强度；二、降低公式的可读性；三、降低运算速率；四、不利于脑力的发挥和开掘，使人懒惰。
         例一：A1为一个数值，其范围为1-7，B1设置公式，按A1数值变化分别等于A-G。
         先来看看纯粹使用if的解法：=IF(A1=1,"a",IF(A1=2,"b",IF(A1=3,"c",IF(A1=4,"d",IF(A1=5,"e",IF(A1=6,"f",IF(A1=7,"g","")))))))
         是不是很麻烦？何止是麻烦，假如再增加两个条件，A1的数值范围为1-26，B1相应取值为A-Z，你又当如何？
         if的嵌套最大可以为7层，上面的公式已经用到了极限。虽然说可以用一些旁门左道来“突破”这个限制，但也只是一种堆沙式的游戏，如上例，可以采用以下方式：=IF(A1=1,"a",IF(A1=2,"b",IF(A1=3,"c",IF(A1=4,"d",IF(A1=5,"e",IF(A1=6,"f",IF(A1=7,"g","")))))))& amp;IF(A1=8,"h",IF(A1=9,"I",""))……
         这样的用法，真是叫人兴味荡然，昏昏欲睡，EXCEL何必还要学下去，还不如去跟儿子摆积木更好玩呢！
         所以说，if最好不要多用。不是说不能用，而是说用多了会叫人伤心。
         其实EXCEL里准备了许多办法来替代上面的愚蠢的做法。
         比如CHOOSE函数。=CHOOSE(A1,"a","b","c","d","e","f","g","h","i")，这是不是方便多了？CHOOSE的参数清单可以有29项之多，一般足够你使用了。如果还不够，那么请看下面：
         =LOOKUP(A1,{1,2,3,4,5,6,7,8,9,10;"a","b","c","d","e","f","g","h","i","j"})，你可以尽情地输入参数，只要公式内容长度允许（规定公式内容长度为1024个字符）。
         如果真的如例中所举，只是生成A-Z等字母的话，则只需=CHAR(A1+64)就可以了。当然，实际使用中这样的巧合实在是太少了，但作为一种方法还是有提及的必要。
         一个if只能处理一个有无或是否的问题，即使这个问题可能是由诸多小的方面组合而成的。我们可以利用这一点，来达到替代if使用的目的。
         例二：公司结算日期为每月24日，帐目的月份一栏，如果超过24日，就要记为下月。
         如果按照普通思路，公式应该是这样的：=IF(DAY(A1)>24,IF(MONTH(A1)=12,1,MONTH(A1)+1),MONTH(A1))
         要用到两个if判断，外层的是判断日期是否大于24，内层的是判断月份是否在12月，因为12月的下月是1月而非13月。现在对比一下下面的公式：
         =MONTH(DATE(YEAR(A1),MONTH(A1)+1,0)+(DAY(A1)>24))
         后者用了A1日期当月最后一天的序列值，最重要的是后面加了一个由判断是否大于24而生成的逻辑值，相当于=if(day(a1)> 24,1,0)。逻辑值在公式设置中是一个很重要的概念，是对问题本身的逻辑关系的判断，其中TRUE=1，FALSE=0，生成的同样是有无或是否的结果，用得恰当，会使你的公式格外生动有趣。类似的还有根据年龄计算性别、年龄的公式，也是使用逻辑值做判断，具体见我以前的相关帖子，此处不在赘述。
         是不是一定要少用if，以至于该用的也想办法不用？我曾经说，最少用到if的公式往往是最好的公式。之所以用“往往”来做限制，就是因为我没有根据来做一定如此的定论。凡事都要实事求是，具体情况具体分析。
         例三：A1为性别，B1为年龄，C1标注是否退休。条件是男60岁，女55岁。
         对这个问题，=IF(OR(AND(A1="男",B1>=60),AND(A1="女",B1>=55)),"退","未退")只用到一个if，但未必就比=IF(B1-IF(A1="男",5)>=55,"退","未退")更简洁，尽管后者用到两个if判断。当然我还是反对=IF(AND(A1="男",B1>=60),"退",IF(AND(A1="女",B1>=55),"退","未退"))这种用法的。
         就写这么多，欢迎批评。

            更正："类似的还有根据年龄计算性别、年龄的公式",前一个“年龄”应该是“身份证”，抱歉。

   作者： juyouhh    2005-10-11 22:04 　回复此发言

回复：if不可不用，不可多用
   多看多用多学多总结嘛，谁天生就会？
         比如我看到http://post.baidu.com/f?kz=48756270 中juyouhh
         的那个公式=SUM((CODE(MID(A1,ROW(INDIRECT("a1:a"&LEN(A1))),1))> 45216)*1)，其中的ROW(INDIRECT("a1:a"&LEN(A1)))就是一个很好的例子，是一个怎么在数组公式中取得连续序列的很好的实例，这样看这个公式就不仅仅只是看到整个公式的功能，而应该是学到一些解决问题的思路*~_~*

   作者： bengdeng    2005-10-12 08:50

如何判斷一個字串中存在中文字元

如何判斷一個字串中存在中文字元

方法一、
看字元的ASC
小於0的為中文
Private Sub Command1_Click()
MsgBox CT(Text1.Text) 'True：有中文；False：無中文
End Sub

Private Function CT(Text As String) As Boolean
Dim l As Long
Dim i As Long
l = Len(Text)
CT = False
For i = 1 To l
If Asc(Mid(Text, i, 1)) < 0 Then
CT = True
Exit Function
End If
Next
End Function

方法二、
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Private Sub Command1_Click()
Dim strSrc As String
strSrc = "abc中文"
If lstrlen(strSrc) - Len(strSrc) > 0 Then
Debug.Print "strSrc中包含雙位元組字元"
Else
Debug.Print "strSrc中不包含雙位元組字元"
End If
strSrc = "abcdef"
If lstrlen(strSrc) - Len(strSrc) > 0 Then
Debug.Print "strSrc中包含雙位元組字元"
Else
Debug.Print "strSrc中不包含雙位元組字元"
End If
End Sub

方法三、
Strlen() 中文化字串長度，相對Len()
StrLeft() 中文化取左字串，相對Left()
StrRight() 中文化取右字串，相對Right()
isChinese() Check某個字是否中文字
Public Function SubStr(ByVal tstr As String, start As Integer, Optional leng As Variant) As String
Dim tmpstr As String
If IsMissing(leng) Then
tmpstr = StrConv(MidB(StrConv(tstr, vbFromUnicode), start), vbUnicode)
Else
tmpstr = StrConv(MidB(StrConv(tstr, vbFromUnicode), start, leng), vbUnicode)
End If
SubStr = tmpstr
End Function
Public Function Strlen(ByVal tstr As String) As Integer
Strlen = LenB(StrConv(tstr, vbFromUnicode))
End Function
Public Function StrLeft(ByVal str5 As String, ByVal len5 As Long) As String
Dim tmpstr As String
tmpstr = StrConv(str5, vbFromUnicode)
tmpstr = LeftB(tmpstr, len5)
StrLeft = StrConv(tmpstr, vbUnicode)
End Function
Public Function StrRight(ByVal str5 As String, ByVal len5 As Long) As String
Dim tmpstr As String
tmpstr = StrConv(str5, vbFromUnicode)
tmpstr = RightB(tmpstr, len5)
StrLeft = StrConv(tmpstr, vbUnicode)
End Function
Public Function isChinese(ByVal asciiv As Integer) As Boolean
If Len(Hex$(asciiv)) > 2 Then
isChinese = True
Else
isChinese = False
End If
End Function

方法四、
Dim m_Str1 As String,m_Str2 As String
m_Str1 ="hjlkj卓越。"
m_Str2= StrConv(m_Str1, vbFromUnicode )
if lenB(m_Str1)<>lenB(m_Str2) then
'字串中存在中文字元。
end if

破解Excel 保護工作表的密碼

破解Excel 保護工作表的密碼
以下VBA可以查出[保護工作表]的密碼.
此為4位數的[英數密碼], 可自行修改以符合自己的需求.
Sub JackyCP()
Dim DimArr(63)
Dim PW As String
For x = 48 To 57
xx = xx + 1
DimArr(xx) = Chr(x)
Next
For x = 97 To 122
xx = xx + 1
DimArr(xx) = Chr(x)
NextFor x = 65 To 90
xx = xx + 1 DimArr(xx) = Chr(x)Next
On Error Resume Next
For x1 = 1 To UBound(DimArr) - 1
For x2 = 1 To UBound(DimArr) - 1
For x3 = 1 To UBound(DimArr) - 1
For x4 = 1 To UBound(DimArr) - 1
PW = DimArr(x1) & DimArr(x2) & DimArr(x3) & DimArr(x4)
Application.StatusBar = PW
ActiveSheet.Unprotect PW
If ActiveSheet.ProtectContents = False Then
MsgBox "Password is " & PW
Exit Sub
End If
Next
Next
Next Next
End Sub

快速判斷儲存格範圍是否存在部份合併儲存格

Sub IsMergeCell()
If Range("A1").MergeCells=True Then
Msgbox "包含合併儲存格"
Else
Msgbox"沒有包含合併儲存格"
End If
End Sub

Sub IsMergeCell()
If IsNull (Range("A1:E10").MergeCells) Then
Msgbox "包含合併儲存格"
Else
Msgbox"沒有包含合併儲存格"
End If
End Sub

使用巨集程式碼在儲存格中建立公式

在EXCEL中函數與公式無疑是實現強大功能的重要組成部份. 在某些情況下, 在VBA中使用公式能更簡單快捷地實現使用者所需要的結果. 下列為如何使用程式碼在儲存格中輸入公式的例子:

Sub UsedFormula()
with Range("A3")
If .HasFormula=True Then          'range物件的HasFormula屬性判斷出儲存格A3中有公式存在
MsgBox "A3儲存格中已有公式"
Else
   .Formula="=A1&A2"        '為儲存格輸入公式
   .FormulaHidden=True       '設定將指定儲存格中的公司隱藏(工作表處於保護狀態時才生效)
End if
End with
End Sub

TARGET.COLUMN使用一簡例

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ERRORFREE

'利用TARGET.COLUMN功能，讓游標到達F欄時，自動跳到下一ROW的D欄備用

If Target.Row < 19 Then Exit Sub '起始行號為19
If Target.Column = 6 Then
Target.Offset(1, -2).Select
End If
If Target.Offset(-1, -2).Value = "貼錯Label" Then
Beep
MsgBox "貼錯Label"
End If
If Target.Offset(-1, -2).Value = "重覆,再掃描" Then
Beep
MsgBox "重覆,再掃描"
End If

ERRORFREE:
Exit Sub

End Sub

一次性修改31份相同內容的工作紙內容

Sub ex()

For i = 1 To 31
   With Sheets(CStr(i))
      .Unprotect "12345" '解開保護
      .[S2] = "21:00"
      .[I12] = Sheets("1").[I12].Value
       Sheets("1").[N1:N20].Copy .[N1]
' 一個WITH...END WITH中包含另一個/多個WITH...END WITH

With .[A15:A99].Validation       '在A15至A99之間設立參照絕對值M1至M15的下拉式選單
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$M$1:$M$15"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
       End With
       With .[B15:B99].Validation    '在B15:B99之間設立下拉式選單
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$L$1:$L$15"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
       End With
       With .[F15:F99].Validation   '在F15至F99之間設立下拉式選單
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$K$1:$K$15"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
       End With

      .Protect "12345" '設定保護
   End With
Next
End Sub

將檔案另存新檔,檔名結構為"年月日.XLS"

以下程式為將另存的新檔存入同檔資料夾內:
With ThisWorkbook
　　.SaveCopyAs .Path & "\" & Format(Date, "yymmdd") & ".xls"
End With

如何取得worksheet名稱

sub wkshtname()

For i = 1 To Sheets.Count
MsgBox Sheets(i).Name
Next

end sub

各種EXCEL VBA的命令參考寫法

‘本示例為設置密碼視窗 (1)
If Application.InputBox("請輸入密碼：") = 1234 Then
[A1] = 1 '密碼正確時執行
Else: MsgBox "密碼錯誤，即將退出！" '此行與第2行共同設置密碼
End If

’本示例為設置密碼視窗 (1)
X = MsgBox("是否真的要結帳？", vbYesNo)
If X = vbYes Then
Close

’本示例為設置工作表密碼
ActiveSheet.Protect Password:=641112 ' 保護工作表並設置密碼
ActiveSheet.Unprotect Password:=641112 '撤銷工作表保護並取消密碼

'本示例關閉除正在運行本示例的工作簿以外的其他所有工作簿，並保存其更改內容

For Each w In Workbooks
If w.Name ThisWorkbook.Name Then
w.Close SaveChanges:=True
End If
Next w

'每次打開工作簿時，本示例都最大化 Microsoft Excel 視窗。
Application.WindowState = xlMaximized

'本示例顯示活動工作表的名稱。
MsgBox "The name of the active sheet is " & ActiveSheet.Name

'本示例保存當前活動工作簿的副本。
ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS"

'下述過程啟動工作簿中的第四張工作表。
Sheets(4).Activate

'下述過程啟動工作簿中的第1張工作表。
Worksheets(1).Activate
'本示例通過將 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
在本示例中，如果活動工作簿不能進行防寫，那麼 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
本示例顯示活動工作簿中每個工作表的名稱。
For Each ws In Worksheets
MsgBox ws.Name
Next ws
本示例關閉除正在運行本示例的工作簿以外的其他所有工作簿，並保存其更改內容。
For Each w In Workbooks
If w.Name ThisWorkbook.Name Then
w.Close savechanges:=True
End If
Next w

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

BeforeDoubleClick 事件
應用於 Worksheet 物件的 Activate 方法。
當雙擊某工作表時產生此事件，此事件先於默認的雙擊操作。
Private Sub expression_BeforeDoubleClick(ByVal Target As Range, Cancel

As Boolean)
expression 引用在類模組中帶有事件聲明的 Worksheet 類型物件的變數。
Target 必需。雙擊發生時最靠近滑鼠指標的單格。
Cancel 可選。當事件發生時為 False。如果事件過程將該參數設為 True，則該
過程執行完之後將不進行默認的雙擊操作。

BeforeRightClick 事件
應用於 Worksheet 物件的 Activate 方法。
當用滑鼠右鍵單擊某工作表時產生此事件，此事件先於默認的右鍵單擊操作。
Private Sub expression_BeforeRightClick(ByVal Target As Range, Cancel

As Boolean)
expression 引用在類模組中帶有事件聲明的 Worksheet 類型物件的變數。
Target 必需。右鍵單擊發生時最靠近滑鼠指標的單格。
Cancel 可選。當事件發生時為 False。如果該事件過程將本參數設為 True，則
該過程執行結束之後不進行默認的右鍵單擊操作。

Change 事件
當用戶更改工作表中的單格，或外部鏈結引起單格的更改時產生此事件。
Private Sub Worksheet_Change(ByVal Target As Range)
Target 更改的區域。可以是多個單格。
說明
重新計算引起的單格更改不觸發本事件。可使用 Calculate 事件俘獲工作表重新
計算操作。
本示例將更改的單格的顏色設為藍色。
Private Sub Worksheet_Change(ByVal Target as Range)
Target.Font.ColorIndex = 5
End Sub

Deactivate 事件
圖表、工作表或工作簿從活動狀態轉為非活動狀態時產生此事件。
Private Sub object_Deactivate()
object Chart、Workbook 或者 Worksheet。有關對 Chart 物件使用事件的詳細
資訊，請參閱 Chart 物件事件的用法。
本示例當工作簿轉為非活動狀態時，對所有打開的視窗進行排列。
Private Sub Workbook_Deactivate()
Application.Windows.Arrange xlArrange
End Sub

FollowHyperlink 事件
當單擊工作表上的任意超鏈結時，發生此事件。對於應用程式級或工作簿級的事件，
請參閱 SheetFollowHyperlink 事件。
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Target Hyperlink 類型，必需。一個代表超鏈結目標位置的 Hyperlink 物件。
本示例對在當前活動工作簿中訪問過的所有鏈結保留一個列表或歷史記錄。
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
With UserForm1
.ListBox1.AddItem Target.Address
.Show
End With
End Sub

PivotTableUpdate 事件
發生在工作簿中的樞紐分析表更新之後。
Private Sub expression_PivotTableUpdate(ByVal Target As PivotTable)
expression 引用在類模組中帶有事件聲明的 Worksheet 類型物件的變數。
Target 必需。選定的樞紐分析表。
本示例顯示一則消息，說明樞紐分析表已經更新。本示例假定您已在類模組中聲明了
帶有事件的 Worksheet 類型的對象。
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
MsgBox "The PivotTable connection has been updated."
End Sub

SelectionChange 事件
當工作表上的選定區域發生改變時，將產生本事件。
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Target 新選定的區域。
本示例滾動工作簿視窗，直至選定區域位於視窗的左上角。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveWindow
.ScrollRow = Target.Row
.ScrollColumn = Target.Column
End With
End Sub
本示例顯示活動工作簿中工作表 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"
本示例關閉工作簿 Book1.xls，但不提示用戶保存所作更改。Book1.xls 中的所有
更改都不會保存。
Application.DisplayAlerts = False
Workbooks("BOOK1.XLS").Close
Application.DisplayAlerts = True
本示例設置保存檔時顯示提示，要求用戶輸入匯總資訊。
Application.PromptForSummaryInfo = True
本示例顯示 Microsoft Excel 的完整路徑。
Private Sub aa()
MsgBox "The path is " & Application.Path
End Sub
示例顯示每一個可用增益集的路徑及檔案名。
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 ' 更改檔案名，並移動檔。
本示例顯示當前默認檔路徑。
MsgBox "The current default file path is " & _
Application.DefaultFilePath
本示例設置替換啟動檔夾。
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
你點選任何單格，按 Selection 按鈕，則則所點選的單格均會被輸入文字

"Test"。
Public Sub Selection1()
Selection.Value = "Test" '在任何你點選的單格輸入文字 "Test"。
End Sub

VBALesson2 程式說明：
幾種如何把別的工作表 Sheet4 資料，讀到這個工作表的方法：在被讀取的單格
前加上工作表名稱 Sheet4。
Public Sub Writes()
1-- 2 方法，最簡單在被讀取的 "[ ]" 前加上被讀取的工作表名稱 Sheet4。
1 [A1] = Sheet4.[A1] '把Sheet4 A1 單格的數據，讀到 A1單格。
2 [A2:A4] = Sheet4.[B1] ''把 Shee4 工作表單格 B1 資料，讀到 A2:A4
單格。
3-- 4 方法，在被讀取的工作表 Range(" ")的 Range 前加上被讀取的工作表名稱

Sheet4。
3 Range("B1") = Sheet4.Range("B1") ''把 Shee4工作表單格 B1 資料，讀
到 B1 單格。
4 Range("C1:C3") = Sheet4.Range("C1") '把 Shee4 工作表單格 C1 資料
，讀到 C1:C3 單格。
5-- 6 方法，在被讀取的工作表 Cells(Row,Column)，Cells 前加上被讀取工作表
名稱 Sheet4。
5 Cells(1, 4) = Sheet4.Cells(1, 4) '把 Shee4 工作表單格 D1 資料，讀
到 D1 單格。
6 Range(Cells(1, 5), Cells(5, 5)) = Sheet4.Cells(1, 5) '把 Shee4 工
作表單格 E1 數據，讀到 E1:E 5單格。
End Sub
你點選任何單格，按 Selection 按鈕，則所點選的單格均會被輸入 Shee4 工
作表單格 F1 數據。
Public Sub Selection1()
Selection.Value = Sheet4.[F1] '把 Shee4 工作表單格 F1 資料，讀到任
何你點選的單格。
End Sub

VBALesson3 程式說明：
如何利用 Worksheet_SelectionChange 輸入資料的方法。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Target = 100
End Sub

Target 指的是你滑鼠所選的單格，Worksheet_SelectionChange() 事件的參數
。
可以是一個也可以是好幾個單格。
Range 是 Excel 特有的變數形態，叫範圍。
Target As Rang 是把 Target 這個參數設定為 Range 變數形態。
Target = 100 是把你點選的單格輸入數位100。

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

If ... Then ... End If 這是我們學的這一個邏輯判斷語句。
Target.Row >= 2，指的是滑鼠選定的單格的行大於或等於 2。
Target.Column = 2 ，指的是滑鼠選定的單格的欄等於 2。
If Target.Row >= 2 And Target.Column = 2 Then 指的是只有在Target.Row >=

2及Target.Column = 2二個條件成立時。
就是 (Target.Row >= 2) 為True及(Target.Column = 2)為True時，才執行下麵的
程式 Target=100，
也就是 B 欄第二行及以下行用滑鼠被點選時，才會被輸入100，其他單格則不被輸
入數據。

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
跟VBALesson 6比較，程式是不是明朗多了，在前課重複的用 Target.Row，

Target.Column及Target來寫程式是不是有一點煩。用變數的第一個好處大家馬上感
覺得出來，就是可以簡化程式。
使用變數前，你得先宣告變數。宣告變數的方法是在 "Dim " 後面寫上變數 " i

" As 後面接上變數的形態 "Integer"。
Dim i , j As Integer 就是宣告 i 與 j 為整數變數，這是同時宣告二個變數

i 與 j 所以要在二個變數間加個 " , "號。
Dim k As Range 是宣告 k 為範圍資料形態，Range這是 Excel 特有的資料形態
。
i = Target.Row是把當前單格的行數，指定給變數 i。
j = Target.Column 是把當前單格的欄數，指定給變數 j。
Set k = Target 是把當前的單格，指定給變數 k。
用像 i 與 j 這樣簡單的變數，在程式的前面你可能還記得 i 或 j 代表著
什厶。程式寫長了，你可能忘記 i 或 j 代表著什厶。所以最好的方法是用比較有
意義的代號，來為變數命名如 iRow 或 iCol 來取代 i 及 j 。

VBALesson 8 程式說明∶體會一下Worksheet_Change()事件。

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()事件。

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
基於VB和EXCEL的報表設計及列印
　　在現代管理資訊系統的開發中，經常涉及到資料資訊的分析、加工，
最終還需把統計結果形成各種形式的報表提供給領導決策參考，或進行外
部交流。在Visual Basic中製作報表，通常是用資料環境設計器(Data
Environment Designer)與資料報表設計器(Data Report Designer),或者
使用第三方產品來完成。但對於大多數習慣於Excel報表的用戶而言,用以
上方法生成的報表在格式和功能等方面往往不能滿足他們的要求。
　　由於Excel具有自己的物件庫，在Visual Basic工程中可以加以引用，
通過對Excel使用OLE自動化，可以創建一些外觀整潔的報表，然後列印輸
出。這樣實現了Visual Basi應用程式對Excel的控制。本文將針對一個具
體實例，闡述基於VB和EXCEL的報表設計及列印過程。
　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
　　以上是提高VBA運行效率的比較有效的幾種方法
本示例重複最近用戶介面命令。本示例必須放在宏的第一行。
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 = "\\zdserver2\HP 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 = "\\zdserver2\HP 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 = "\\zdserver2\HP 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
自定義功能表
把建立和刪除自定義功能表的代碼分別寫在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

訂閱：文章 (Atom)