PCMAN

我的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

在ACCESS中DLOOKUP的用法(轉載)

語法：    DLookup(expr, domain, [criteria])

參數解釋：
    expr：要取得值的字段名稱
    domain ：要取得值的表或查詢名稱
    criteria：用于限制 DLookup 函數執行的數據範圍。如果不給 criteria 提供值，Dlookup 函數將返回DOMAIN中的一个随機值。

正常用法:-
    用於數值型條件值:
DLookup("字段名稱" , "表或查詢名稱" , "條件字段名 = n")

    用于字符串型條件值:(注意字符串的單引號不能丢失)
DLookup("字段名稱" , "表或查詢名稱" , "條件字段名 = '字符串值'")

    用于日期型條件值:(注意日期的"#"號不能丢失)
DLookup("字段名稱" , "表或查詢名稱" , "條件字段名 = #日期值#")

从窗體控件中引用條件值用法:-
    用於數值型條件值:
DLookup("字段名稱" , "表或查詢名稱" , "條件字段名 =" &   forms!窗體名!控件名)

    用於字符串型條件值:(注意字符串的單引號不能丢失)
DLookup("字段名稱" , "表或查詢名稱" , "條件字段名 = '" &   forms!窗體名!控件名 & "'")
    用於日期型條件值:(注意日期的"#"號不能丢失)
DLookup("字段名稱" , "表或查詢名稱" , "條件字段名 = #" &   forms!窗體名!控件名 & "#")

混合使用方法(支持多條件):-
    在這種方法中也可以在條件中寫入固定的值。
    DLookup("字段名稱" , "表或查詢名稱" , "條件字段名1 = " & Forms!窗體名!控件名1 _
            & " AND 條件字段名2 = '" & Forms!窗體名!控件名2 & "'" _
            & " AND 條件字段名3 =#" & Forms!窗體名!控件名3 & "#")

Access一些指令之一

Option Compare Database
Const DB_Text As Long = 10
Const DB_Boolean As Long = 1
'禁止全部菜單
ChangeProperty "AllowFullMenus", DB_Boolean, False
'允許全部菜單
ChangeProperty "AllowFullMenus", DB_Boolean, True
'清除啟動窗口
ChangeProperty "StartupForm", DB_Text, "(none)"
'禁止查看代碼
ChangeProperty "AllowBreakIntoCode", DB_Boolean, False
'禁止數據庫窗口
ChangeProperty "StartupShowDBWindow", DB_Boolean, False
'禁止使用[shift]鍵
ChangeProperty "AllowBypassKey", DB_Boolean, False
'禁止特殊鍵
ChangeProperty "AllowSpecialKeys", DB_Boolean, False
'禁止狀態欄
ChangeProperty "StartupShowStatusBar", DB_Boolean, False
'禁止內置工具欄
ChangeProperty "AllowBuiltinToolbars", DB_Boolean, False
****************************
以下為為ACCESS檔進行資料壓縮及修復的指令(適合繁體中文)。
使用時, ACCESS都是需要獨佔(沒有第二者使用之下)才可以運作。

Private Sub repairbtn_Click()
CommandBars("Tools"). _
Controls("資料庫公用程式(&D)"). _
Controls("壓縮及修復資料庫(&C)..."). _
accDoDefaultAction
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

ACCESS SQL - INSERT INTO 及 UPDATE語法

我們已經學到了如何把資料由表格中取出。
但是這些資料是如果進入這些表格的呢？通過 (INSERT INTO) 和 (UPDATE) 便可以做到。

INSERT INTO語法:-
基本上，我們有兩種作法可以將資料輸入表格中:
1. 一次輸入一筆，
2. 一次輸入好幾筆。

一次輸入一筆資料的語法如下：
INSERT INTO "表格名" ("欄位1", "欄位2", ...)
VALUES ("值1", "值2", ...)
假設我們有一個架構如下的表格：
Store_Information 表格

Column Name	Data Type
store_name	char(50)
Sales	float
Date	datetime

我們要加以下這一筆資料進去這個表格：在 January 10, 1999，Los Angeles 店有 $900 的營業額。我們就打入以下的 SQL 語句：
INSERT INTO Store_Information (store_name, Sales, Date)
VALUES ('Los Angeles', 900, 'Jan-10-1999')

一次輸入多筆的資料：
跟上面的例子不同的是，現在我們要用 SELECT 指令來指明要輸入表格的資料。如果您想說，這是不是說資料是從另一個表格來的，那您就想對了。一次輸入多筆的資料的語法是：
INSERT INTO "表格1" ("欄位1", "欄位2", ...)
SELECT "欄位3", "欄位4", ...
FROM "表格2"
以上的語法是最基本的。這整句 SQL 也可以含有 WHERE、 GROUP BY、及 HAVING 等子句，以及表格連接及別名等等。
舉例來說，若我們想要將 1998 年的營業額資料放入 Store_Information 表格，而我們知道資料的來源是可以由 Sales_Information 表格取得的話，那我們就可以鍵入以下的 SQL：
INSERT INTO Store_Information (store_name, Sales, Date)
SELECT store_name, Sales, Date
FROM Sales_Information
WHERE Year(Date) = 1998
在這裡，我用了 SQL Server 中的函數來由日期中找出年。不同的資料庫會有不同的語法。舉個例來說，在 Oracle 上，您將會使用 WHERE to_char(date,'yyyy')=1998。

UPDATE語法：-
我們有時候可能會需要修改表格中的資料。在這個時候，我們就需要用到 UPDATE 指令。這個指令的語法是：
UPDATE "表格名"
SET "欄位1" = [新值]
WHERE {條件}
最容易瞭解這個語法的方式是透過一個例子。假設我們有以下的表格：
Store_Information 表格

store_name	Sales	Date
Los Angeles	$1500	Jan-05-1999
San Diego	$250	Jan-07-1999
Los Angeles	$300	Jan-08-1999
Boston	$700	Jan-08-1999

我們發現說 Los Angeles 在 01/08/1999 的營業額實際上是 $500，而不是表格中所儲存的 $300，因此我們用以下的 SQL 來修改那一筆資料：
UPDATE Store_Information
SET Sales = 500
WHERE store_name = "Los Angeles"
AND Date = "Jan-08-1999"
現在表格的內容變成：
Store_Information 表格

store_name	Sales	Date
Los Angeles	$1500	Jan-05-1999
San Diego	$250	Jan-07-1999
Los Angeles	$500	Jan-08-1999
Boston	$700	Jan-08-1999

在這個例子中，只有一筆資料符合 WHERE 子句中的條件。如果有多筆資料符合條件的話，每一筆符合條件的資料都會被修改的。
我們也可以同時修改好幾個欄位。這語法如下：
UPDATE "表格"
SET "欄位1" = [值1], "欄位2" = [值2]
WHERE {條件}

ACCESS表單放大縮小指令

DoCmd.Restore 回復原本大小
DoCmd.Maximize 最大化
DoCmd.Minimize 最小化
DoCmd.MoveSize [right][, down][, width][, height] 自訂大小
以上是用在VBA程式碼中,(可以放在form 的 on open事件裡)
也有相對應的巨集可用.(去掉docmd,就是它們的原本的巨集名稱)
這些方法只能改自身表單,不能改非[程式碼模組所屬表單] 的其他表單.

利用DLOOKUP()函數在ACCESS表單中做查詢

我想要做一個可以在執行表單時，在表單裡面做輸入我要的值然後查詢並直接從資料表中找到資料。
--------------------------------------------------------------------------------------------------------------------------------------
EX:
資料表----客戶資料

識別碼:35
姓名:某某某
連絡電話:****-****
出生年月日:54/5/6

表單----客戶資料

識別碼:
姓名:
連絡電話:
出生年月日:

在表單中建立查詢>然後我要輸入出生年月日和姓氏就可以跳出以上資料。

答案:

Private Sub 姓名_AfterUpdate()
If IsNull(DLookup([姓名], "客戶資料", "姓名='" & Me![姓名] & "'")) Then
MsgBox "找不到你輸入的資料"
Exit Sub
End If
Me![識別碼] = DLookup([識別碼], "客戶資料", "姓名='" & Me![姓名] & "'")
Me![姓名] = DLookup([姓名], "客戶資料", "姓名='" & Me![姓名] & "'")
Me![連絡電話] = DLookup([連絡電話], "客戶資料", "姓名='" & Me![姓名] & "'")
Me![出生年月日] = DLookup([出生年月日], "客戶資料", "姓名='" & Me![姓名] & "'")
End Sub

注意,表單上的那4個資料項最好不要和資料庫連接, 要非結合狀態,這樣比較不會出其他問題.
因為上面已經用最簡單的方法去做,不想搞大. 單純只有用到 DLookup()函數來處理.
還有, DLookup()只能給你 1 個資料,多出來的不處理.

ACCESS資料表中輸入重覆資料便會出提示窗口並停止輸入

問:-
在 Access 有一 Custom 的資料表，內有CCard 欄位(設定: 數字，非自動號碼，不可重履).
以下是Afterupdate 的設定：
Private Sub addNewCCard_AfterUpdate()
If DLookup("CCard", "Custom", CCard = Me![addNewCCard]) Then

     MsgBox ("This C Card used")

End If

End Sub

但是如果我在Custom資料表CCard中輸入已存在的號碼，郤沒有如設定般出現 MsgBox 內容，
而且還可以繼續跳到下一欄位繼續輸入，請問哪裡出現問題？

答:-
改一下變數條件位置如下所示：
If DLookup("CCard", "Custom", "[CCard]=" & Me![addNewCCard] & "") Then

訂閱：文章 (Atom)