PCMAN: 2013

在ACCESS中編寫"起始日期"為當月第一天，"終止日期"為當天的代碼

在ACCESS中如何編寫"起始日期"為當月第一天，"終止日期"為當天的代碼？

[方法一]

設置文本框的默認值為：-

=Format(Date(),"yyyy-mm-""01""") - 當月的第一天

=Format(Date(),"yyyy-mm-dd") - 當天

以上設定的缺點：得出來的值是文本型，無法實現日期範圍鎖定的篩選，也無法按照日期先後排序。

[方法二]

改善以上的缺點

設置文本框的默認值為：-

當前該月份的第一天(即某月一日)=CDATE(Format(Date(),"yyyy-mm") & "-1")

當前日期=Date()

有用應用連結

有用VBA資料/網站/網誌連結：- http://vba.blogspot.com/
http://www.wretch.cc/blog/HUNGCHILIN/蜥蜴網路交流Blog http://tw.myblog.yahoo.com/ceyi-udwebs/

公式輸入的常用技巧

1.陣列公式輸入方法是Ctrl+Shift+Enter三鍵一起完成輸入

2.公式中--代表意義:--就解讀成負負得正就是將數字型的字串轉換成數值

如:M10234要取得10234成為數值使用，先以MID或RIGHT等字串函數來取得

=RIGHT("M10234",5)這樣得到10234是字串型態

=--RIGHT("M10234",5)這樣得到10234是數值型態

3.輸入公式時善用f4鍵切換位址的相對或絕對參照。

Excel 2003的規格及限制(摘錄自Excel 說明)

Excel2003 的規格及限制　

工作表和活頁簿規格

特性最大限制
開啟活頁簿受限於可用的記憶體和系統資源
工作表大小 65,536 列 * 256 欄
欄寬 255 個字元
列高 409 個點數
分頁線 1000 條水平及垂直線
儲存格內容的長度 (文字) 32,767 個字元。在一個儲存格中僅能顯示1,024 個字元；在資料編輯列顯示全部 32,767 個字元。
活頁簿中檢視個數受限於可用的記憶體 (預設值是 3 個工作表)
活頁簿中的色彩個數 56
活頁簿中儲存格樣式個數 4,000
活頁簿中具名的檢視表 (檢視表：可命名及套用至活頁簿的一組顯示及列印設定。您可以建立一個活頁簿的多個檢視表，而無需儲存活頁簿的個別複本。)個數受限於可用的記憶體
自訂數字格式介於 200 和 250 之間 (根據您安裝的 Excel 語言版本而定)。
在活頁簿中的名稱受限於可用的記憶體
在活頁簿中的視窗受限於系統資源
在視窗中的窗格 4
連結工作表受限於可用的記憶體
分析藍本 (分析藍本：工作表模型中可取代的一組已命名的輸入值。) 受限於可用的記憶體；一個摘要報表只能顯示前 251 個分析藍本
在分析藍本中變更儲存格 32
調整歸劃求解的儲存格 200
自訂函數受限於可用的記憶體
顯示比例範圍 10 % 到 400 %
報表受限於可用的記憶體
參照排序在單一排序中為 3；若是使用循序排序則無限制
還原階層 16
在資料表單中的欄位 32
在活頁簿中自訂工具列受限於可用的記憶體
自訂工具受限於可用的記憶體

工作群組規格

特性最大限制
使用者可在同一時間內開啟及共用一個共用活頁簿 (共用活頁簿：為允許網路上的多位使用者同時檢視及進行變更而設定的活頁簿。儲存活頁簿的每位使用者均可查看其他使用者所做的變更。)。 256
共用活頁簿中個人的檢視表 (檢視表：可命名及套用至活頁簿的一組顯示及列印設定。您可以建立一個活頁簿的多個檢視表，而無需儲存活頁簿的個別複本。)個數受限於可用的記憶體
保存變更歷程記錄 (變更歷程記錄：共用活頁簿中保存之過去編輯作業中所作變更的相關資訊。此類資訊包括進行變更的人員姓名、變更的時間，以及變更的資料內容。)的天數 32,767 (預設值為 30 日)
一次可合併的活頁簿個數受限於可用的記憶體
在共用活頁簿中的儲存格會被標示出來 32,767
當變更反白提示被開啟時，可用來識別不同使用者所做修改的色彩個數。 32 (每個使用者是以不同的色彩來代表；目前使用者所做的變更是以深藍色來標示)

計算規格

特性最大限制
數字精確度 15 位數
儲存格中允許輸入的最大值 9.99999999999999E+307
最大的可容許正數 1.79769313486231E+308
最小的可容許負數 -2.2251E-308
最小的可容許正數 2.229E-308
最大的可容許負數 -1E-307
公式內容的長度 1,024 個字元
反複運算 32,767
工作表陣列因受限於可用記憶體，所以，陣列不可以是整個欄。例如，一個陣列不能是全部的 C:C 欄或者是到 C1:C65536 的範圍。不過，陣列的範圍可以是 C1:D65535，因為此範圍是工件表大小之最大值的列，但並不包括整個 C 或 D 欄。
選取範圍 2,048
在函數中的引數 30
函數的巢狀階層 7
工作表函數的可用數目 329
計算可容許的最早日期 January 1, 1900 (如果使用 1904 的日期系統的話，則為 January 1, 1904)
計算可容許的最晚日期 December 31, 9999
可以輸入的最大時間值 9999:59:59

樞紐分析表規格

特性最大限制
工作表中的樞紐分析表 (樞紐分析表：從不同來源 (包含 Excel 的外部來源) 摘要及分析資料 (如資料庫記錄) 的互動式、跨表格的 Excel 報表。)個數受限於可用的記憶體
每個欄位唯一的項目 32,500
樞紐分析表報表中的列欄位 (列欄位：樞紐分析表中指定了列方向的欄位。與列欄位關聯的項目會顯示為列標籤。)或欄欄位 (欄欄位：樞紐分析表中指定了欄方向的欄位。與欄欄位關聯的項目會顯示為欄標籤。)個數受限於可用的記憶體
樞紐分析表報表中的分頁欄位 (分頁欄位：樞紐分析表或樞紐分析圖中指定給分頁方向的欄位。您可以在分頁欄位中顯示所有項目的摘要，或一次顯示一個項目，這樣就會篩選出所有其他項目的資料。)個數 256 (可能會受限於可用的記憶體)
樞紐分析表報表中的資料欄位 (資料欄位：包含樞紐分析表或樞紐分析圖中所彙總之資料的來源清單、資料表或資料庫內的欄位。資料欄位通常包含統計資料或銷售量之類的數值資料。)的個數 256
樞紐分析表報表中的計算項目 (計算項目：樞紐分析表欄位或樞紐分析圖欄位中使用您建立之公式的項目。計算項目可藉由使用樞紐分析表或樞紐分析圖之相同欄位中的其他項目內容來執行計算。)公式的個數受限於可用的記憶體

圖表規格

特性最大限制
圖表連結到工作表受限於可用的記憶體
一個圖表所能參照的工作表 255
一個圖表中的資料數列 (資料數列：圖表中繪製的相關資料點。圖表中的每個資料數列都有唯一的色彩或圖樣，並以圖表圖例表示。您可以在圖表中繪製一或多個資料數列。圓形圖只有一個資料數列。)的個數 255
平面圖表其資料數列中資料點 (資料點：繪製在圖表上的個別值。相關資料點組成資料數列。資料點由橫條、欄、線、扇區、點及其他圖案來表示。這些圖案稱作資料標記。)的個數 32,000
資料數列中立體圖表的資料點個數 4,000
一個圖表中所有資料數列的資料點個數 256,000
線條樣式 8
線條點數 4
區域圖樣 (螢幕顯示) 18
總共區域圖樣和色彩組合 (彩色顯示) 56,448
圖樣和色彩組合 (彩色列印) 56,448 (實際的個數會因為印表機和它的軟體的差異而有所不同)
樞紐分析圖 (樞紐分析圖：提供資料互動式分析的圖表，與樞紐分析表類似。您可以變更資料的檢視，查看不同層次的細節，或是拖曳欄位及顯示或隱藏欄位中的項目，來重新組織圖表版面配置。)中的分頁欄位 (分頁欄位：樞紐分析表或樞紐分析圖中指定給分頁方向的欄位。您可以在分頁欄位中顯示所有項目的摘要，或一次顯示一個項目，這樣就會篩選出所有其他項目的資料。)個數 256 (可能會受限於可用的記憶體)
樞紐分析表報表中的資料欄位 (資料欄位：包含樞紐分析表或樞紐分析圖中所彙總之資料的來源清單、資料表或資料庫內的欄位。資料欄位通常包含統計資料或銷售量之類的數值資料。)個數 256
在樞紐分析圖中計算項目公式受限於可用的記憶體

Sum函数中*号的妙用

Sum函数中*号的妙用文章作者：Fei Hong 来源：飞鸿工作室

=SUM(’*’!A1) ’*’! ----???
呵呵，用公式时无意弄出这么个东东，’*’! 代表什么？输输看？
如果工作表中有三个工作表Sheet1、Sheet2、Sheet3，你在 Sheet1表中输入这个公式：
=SUM(’*’!A1)，回车，看看公式自动变成了什么？ =SUM(Sheet2:sheet3!A1)
如果你在 Sheet2表中输入这个公式：
=SUM(’*’!A1)，回车，公式自动变成了 =SUM(Sheet1!A1,sheet3!A1)
呵呵，明白了吗？
’*’!--代表工作簿中的出去当前工作表的其他工作表，现在你在用公式的时候，会用这种简单方式吗？
还可以＝SUM('*'!A1:A10)

试了一下，对其它函数（如：sumproduct、sumif、count、countif等）也适用。

動畫錄製軟體分享

<<資料來源: 麻辣家族討論版>>

『GIF動畫錄製工具』是一個現時(2011年8月)為綠色的免安裝免費軟件。
功能：將螢幕畫面錄製成GIF檔案，方便用作教學/解釋問題/介紹軟件或程式的操作過程。
使用方法：將檔案解壓縮即可執行。

如果嫌打開軟件之後見到為"UNREGISTERED"版本礙眼，可跟隨上圖顯示更改其登錄檔中的內容，之後重新開啟即可。
選取錄製範圍：
按下選取範圍，會顯示前次的範圍，重新選取後，虛線會不見，只要勾選顯示範圍就會產生新選取範圍虛線。
就幾個簡單步驟而已
1、選取範圍
當畫面空白時，游標成為十字形。框選錄製的範圍
2、按下開始
螢幕開始倒數讀秒，到0時開始錄製
3、操作完過程，按結束
4、儲存檔案
備註：
要功能強一點的話，就是用camtasia studio，付費軟體。　很多人用，而且功能大。

破解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

在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
****************************

訂閱：文章 (Atom)