在學(xué)習(xí)ExcelVBA編程的過(guò)程中，經(jīng)常會(huì)遇到一些問(wèn)題，有些可能是新碰到的，有些則是以前已遇到過(guò)但暫時(shí)忘掉了解決辦法的，VBA編程問(wèn)答將把我所收集到的問(wèn)題和自已所遇到的問(wèn)題及解決辦法進(jìn)行歸納整理，以方便查閱和參考。
在下面的內(nèi)容中，有大量的程序代碼，并附有簡(jiǎn)單的說(shuō)明，您可以將它們輸入或復(fù)制到VBE編輯器中進(jìn)行調(diào)試，也可以將它們進(jìn)行適當(dāng)?shù)恼{(diào)整和修改后應(yīng)用到自已的程序中。有些問(wèn)答提供了參考示例，您可以直接下載后處理。

   Dim fs, fd, fl As Object
   Dim xlbook As Workbook
   Dim xlsheet As Worksheet
   Dim i_cnt As Integer

   i_cnt = 1

   Set fs = CreateObject("scripting.filesystemobject") '建立filesystemobject

   If Not fs.FolderExists(sPath) Then
      MsgBox "目錄不存在！", vbCritical
      Exit Sub
   End If

    Set fd = fs.getfolder(sPath)   '或取文件夾
    For Each fl In fd.Files        '依此處理文件夾中的文件
      If Right(Trim(fl.Name), 3) = "xls" Then     '只處理xls文件
        Set xlbook = Application.Workbooks.Open(sPath + "\" + fl.Name)  '打開(kāi)xls文件
        If i_cnt <> 3 Then         '默認(rèn)的worksheet數(shù)量是3,如果超過(guò)就自動(dòng)的增加
          Set xlsheet = Application.Workbooks(1).Worksheets.Add
        Else
          Set xlsheet = Application.Workbooks(1).Worksheets(i_cnt)
        End If
        xlbook.Worksheets(1).Rows.Copy xlsheet.Cells(1, 1) '復(fù)制worksheet
        i_cnt = i_cnt + 1
        xlbook.Close             '關(guān)閉已經(jīng)打開(kāi)的xls文件
      End If
    Next
    Set fl = Nothing           '關(guān)閉file,folder,filesystemobject對(duì)象
    Set fd = Nothing
    Set fs = Nothing
End Sub

Sub main()
  Dim sPath As String
  sPath = InputBox("請(qǐng)輸入目錄！如C:", "合并目錄下xls文件的sheet1")  '顯示輸入框獲取磁盤(pán)目錄
  If sPath = " " Then Exit Sub
  Mergesheet (sPath)
End Sub
‘***********************************
===================================================================
問(wèn)題28：關(guān)于Excel單元格填充顏色......？
有五種可能的計(jì)算結(jié)果，比如結(jié)果會(huì)是1,2,3,4,5，不同的值給單元格填充不同顏色。條件格式最多只能定義三個(gè)條件，即只能填充最多三種顏色，不知用什么方法可以填上三種以上的顏色？
解答： 如果所有的結(jié)果集合只是在1，2，3，4，5中間，那么寫(xiě)個(gè)宏就OK。
假設(shè)對(duì)于$B這一整列的情況如下：
B1=0或空時(shí)，單元格B1無(wú)填充顏色；
B1=1 時(shí)，給單元格B1填充紅色；
B1=2 時(shí)，給單元格B1填充藍(lán)色；
B1=3 時(shí)，給單元格B1填充綠色；
B1=4 時(shí)，給單元格B1填充黃色；
B1=5 時(shí)，給單元格B1填充紫色。
B2=0或空時(shí)，單元格B2無(wú)填充顏色；
B2=1 時(shí)，給單元格B2填充紅色；
B2=2 時(shí)，給單元格B2填充藍(lán)色；
B2=3 時(shí)，給單元格B2填充綠色；
B2=4 時(shí)，給單元格B2填充黃色；
B2=5 時(shí)，給單元格B2填充紫色。
……
代碼：
‘***********************************
Sub Macro1()
  For i = 1 To 4096 ‘要填充顏色的單元格，可修改為所需要的
    Range("B" + CStr(i)).Select
    Select Case Range("B" + CStr(i)).Cells.Value
    Case 1
      Selection.Interior.ColorIndex = 3
    Case 2
      Selection.Interior.ColorIndex = 4
    Case 3
      Selection.Interior.ColorIndex = 5
    Case 4
      Selection.Interior.ColorIndex = 6
    Case 5
      Selection.Interior.ColorIndex = 7
    End Select
    With Selection.Interior
      .Pattern = xlSolid
      .PatternColorIndex = xlAutomatic
    End With
  Next
End Sub
‘***********************************
---------------------------------------------------------------------
如果要做到單元格的值改變后填充的顏色自動(dòng)更新，這個(gè)宏該改成怎樣？
如果單元格的值是計(jì)算得來(lái)的，用 worksheet Calculate Event 應(yīng)該可以。
代碼：
‘***********************************
Private Sub Worksheet_Calculate()
  Dim vValue As Integer
  Dim vColor As Integer
  Dim cRange As Range
  Dim cell As Range

  For Each cell In Intersect(Columns("B"), ActiveSheet.UsedRange)
    vValue = cell.Value
    '默認(rèn)值無(wú)填充色
    vColor = 0
    Select Case vValue
    Case 1
      vColor = 3
    Case 2
      vColor = 5
    Case 3
      vColor = 4
    Case 4
      vColor = 6
    Case 5
      vColor = 13
    End Select
    Application.EnableEvents = False
    cell.Interior.ColorIndex = vColor
    Application.EnableEvents = True
  Next cell
End Sub
‘***********************************
( 如果單元格的值不是計(jì)算得來(lái)的，是直接輸入的，可以改用 Worksheet Change Event )
---------------------------------------------------------------------
還想問(wèn)一下，這個(gè)宏的功能能否用自定義函數(shù)做到？
想用自定義函數(shù)的原因：?jiǎn)卧矜i定時(shí)，自定義函數(shù)依然可以正常運(yùn)行，而宏不行。
這個(gè)可以利用 UserInterfaceOnly ＝ TRUE 參數(shù)去解決。將 UserInterfaceOnly 參數(shù)設(shè)置為 True 可以允許通過(guò)代碼修改，但是不允許通過(guò)用戶(hù)界面修改。默認(rèn)值為 False，這意味著通過(guò)代碼和用戶(hù)界面項(xiàng)都不可以修改受保護(hù)的工作表。這個(gè)屬性設(shè)置只適用于當(dāng)前會(huì)話(huà)。如果您想讓代碼可以在任何會(huì)話(huà)中都可以操作工作表，那么您需要每次工作簿打開(kāi)的時(shí)候添加設(shè)置這個(gè)屬性的代碼。
注意紅色那段字，由于這個(gè)原因，所以加一個(gè)宏在 workbook open event 讓每次開(kāi)啟檔案時(shí)去設(shè)定UserInterfaceOnly 參數(shù)。
代碼；
‘***********************************
Private Sub Workbook_Open()
  '如果每個(gè)工作表都有不同的密碼
  Sheets(1).Protect Password:="secret1", UserInterFaceOnly:=True
  Sheets(2).Protect Password:="secret2", UserInterFaceOnly:=True
'按需要重復(fù)
'**如果所有工作表密碼相同
   'Dim wSheet As Worksheet
   'For Each wSheet In Worksheets
   '    wSheet.Protect Password:="secret", UserInterFaceOnly:=True
   'Next wSheet
'****
End Sub
‘***********************************
必須了解的一些相關(guān)概念(陳希章,微軟中文新聞組專(zhuān)家)
一般我們?cè)谥付伾珪r(shí)喜歡用ColorIndex這個(gè)屬性,通常情況下是沒(méi)有問(wèn)題的。
但必須知道的一些概念是:ColorIndex是相對(duì)于調(diào)色盤(pán)中(調(diào)色盤(pán)有56中顏色)的某個(gè)位置的顏色,而調(diào)色盤(pán)是屬于工作簿級(jí)的對(duì)象,也就是說(shuō)很有可能這樣一種情況就是,在這個(gè)工作簿中3代表紅色(假設(shè)),而到另一個(gè)工作簿中卻不是。
所以,如果要精確定義顏色,是不推薦用ColorIndex的,往往有些同志在調(diào)試程序時(shí)的疑惑也在于此(明明在自己電腦上是紅色,到用戶(hù)電腦上就不是了)。
還有兩種方法來(lái)返回顏色：
1.用Excel常量,如vbred,vbblue,vbgreen等。
2.用RGB函數(shù)。
用以上的方法,VBA語(yǔ)句也應(yīng)相應(yīng)更改。
例:Target.Offset(0, 1).Interior.ColorIndex = vColor 改成'Target.Offset(0, 1).Interior.Color = vbred 等等。
另從本例而言,建議統(tǒng)一用change事件。
===================================================================
問(wèn)題29：如何實(shí)現(xiàn)在Sheet1中輸入后，在Sheet2中相應(yīng)的單元格中顯示？
即，如何實(shí)現(xiàn)在
sheet1中輸入a1=abc，sheet2中顯示a1=abc;
   輸入b1=xyz，sheet2中顯示a2=xyz;
       再輸入a2=123，sheet2中顯示a5=123;
             輸入b2=qwe, sheet2中顯示a6=qwe;
       不停的輸入后，sheet2中數(shù)字每四行四行不停填充。
解答：
代碼說(shuō)明，這個(gè)需求的關(guān)鍵是，需要建立sheet1的行列值與sheet2的行值之間的函數(shù)關(guān)系，綜合看就是一個(gè)代數(shù)系統(tǒng)內(nèi)的等差數(shù)列的關(guān)系。 這個(gè)代數(shù)式就是：
j=(i-1)*4+t   j代表sheet2的行值，i代表sheet1的行值，t代表sheet1的列值。
所以能夠按照所描述的功能的vba代碼如下：
‘***********************************
'這是sheet1的worksheet_change事件(觸發(fā)的條件就是在sheet1輸入數(shù)據(jù))
Private Sub Worksheet_Change(ByVal Target As Range) 
    If Target.Column > 2 Then   '這里限定最大只可以輸入到每行的第2列,否則就不處理
      MsgBox "輸錯(cuò)了位置", vbCritical '這里是錯(cuò)誤的提示信息
    Exit Sub                         '退出代碼的執(zhí)行
    End If
   '按照sheet1與sheet2行列的特定算法填充數(shù)據(jù)
   Sheet2.Cells((Target.Row - 1) * 4 + Target.Column, 1) = Target.Value
End Sub
‘***********************************
===================================================================
問(wèn)題30：如何實(shí)現(xiàn)當(dāng)某一單元格滿(mǎn)足非空條件時(shí)，輸入的數(shù)據(jù)不能修改？
如果在excel中寫(xiě)如此要求的一個(gè)函數(shù)：某一單元格滿(mǎn)足非空條件時(shí)，輸入的數(shù)據(jù)不能修改。就是當(dāng)我往一個(gè)單元格內(nèi)輸入數(shù)據(jù)后，其中的數(shù)據(jù)無(wú)法再次修改！
解答：代碼如下：
‘***********************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target <> "" Then
   Target.Locked = True
   ActiveSheet.Protect password:="123"
End If
If Target = "" Then
   ActiveSheet.Unprotect password:="123"
End If
End Sub
‘***********************************
===================================================================
問(wèn)題31：如何用Vba方法導(dǎo)出Xls文件至Txt文件？
即如何以一定的格式輸出Excel文件的數(shù)據(jù)。
解答：
這是個(gè)常見(jiàn)的問(wèn)題，因?yàn)樵S多不同應(yīng)用系統(tǒng)之間報(bào)送數(shù)據(jù)時(shí)，最好的方法就是報(bào)送統(tǒng)一格式的數(shù)據(jù)文件，而帶有特殊分割符號(hào)的文本文件應(yīng)該說(shuō)是最適用的。
下面的代碼將輸出的文件改為“文件名”+“Worksheet名”組合的TXT文件。代碼的適當(dāng)說(shuō)明：生成Txt文件需要使用FileSystemObject對(duì)象，關(guān)于該對(duì)象的說(shuō)明，可以參閱msdn或vba幫助中的相關(guān)內(nèi)容。這段程序可以在將xls文件中任意的sheet中的內(nèi)容導(dǎo)出成txt文本文件。
如下就是代碼。可以將其復(fù)制到任何一個(gè)xls文件中。使用時(shí)，只要打開(kāi)某個(gè)sheet，然后運(yùn)行這個(gè)宏（菜單內(nèi)：工具-〉宏-〉運(yùn)行宏OutPutXlsToTxt），即可將該sheet內(nèi)的數(shù)據(jù)導(dǎo)出生成TXT文件，文件名是由Excel文件名和Sheet名組合而成的。
‘***********************************
Sub OutPutXlsToTxt()
  Dim fs, myFile As Object
  Dim i_row, i_col, i_MaxCol As Integer 'xls工作表的行列坐標(biāo)變量和最大列數(shù)變量
  Dim myfileline As String'txtfile的行數(shù)據(jù)
 
  Set fs = CreateObject("Scripting.FileSystemObject")  '建立filesytemobject
 '通過(guò)filesystemobject新建一個(gè)和xls文件同名的txt文件
  Set myFile = fs.createtextfile(Workbooks(1).Path + "\" + _
    Mid(Trim(Workbooks(1).Name), 1, Len(Trim(Workbooks(1).Name)) - 4) + "之" + _
    Trim(Workbooks(1).ActiveSheet.Name) + ".txt") 
  i_row = 1
  i_MaxCol = 0
  Do
    i_MaxCol = i_MaxCol + 1
  Loop Until Workbooks(1).ActiveSheet.Cells(1, i_MaxCol) = ""
  i_MaxCol = i_MaxCol - 1    '獲得整個(gè)sheet的最大列數(shù)
  If i_MaxCol = 0 Then       '對(duì)沒(méi)有數(shù)據(jù)的表不做處理并退出程序
    MsgBox "該表無(wú)數(shù)據(jù),不能導(dǎo)出!", vbCritical
    Exit Sub
  End If
  Do
    myfileline = ""
    For i_col = 1 To i_MaxCol
      myfileline = myfileline + _
       Trim(CStr(Workbooks(1).ActiveSheet.Cells(i_row, i_col))) + "," '生成每行數(shù)據(jù)
    Next
    myFile.writeline (Mid(myfileline, 1, Len(myfileline) - 1))  '將每行數(shù)據(jù)寫(xiě)入txtfile
    i_row = i_row + 1
  Loop Until Workbooks(1).ActiveSheet.Cells(i_row, 1) = ""
 
  Set myFile = Nothing
  Set fs = Nothing                   '關(guān)閉文件和filesystemobject對(duì)象
End Sub
‘***********************************

By fanjy in 2007-1-20

注：本輯編程問(wèn)答資源整理歸納于vbaexpress、微軟中文技術(shù)社區(qū)等。