Bootstrap

VBA编程问答(第3辑)

本辑目录
问题26:如何实现单元格在指定区域内自动跳转?
问题27:如何将多个工作簿中的工作表一次性合到一个工作簿里面?
问题28:关于Excel单元格填充颜色......?
问题29:如何实现在Sheet1中输入后,在Sheet2中相应的单元格中显示?
问题30:如何实现当某一单元格满足非空条件时,输入的数据不能修改?
问题31:如何用Vba方法导出Xls文件至Txt文件? 
=====================================================================
问题26:如何实现单元格在指定区域内自动跳转?
例如,在单元格区域A1:C100中,无论何时在其中的某个单元格中输入完一个单个的字符后,自动按规律跳转到下一单元格,即在单元格B1中输完后,跳转到单元格C1,在单元格C1中输入完单个字符后,自动跳转到单元格A2,……
解答:可以在工作表事件中使用下面的代码:
‘***********************************
Private Sub Worksheet_Change(ByVal Target As Range)
    Const WS_RANGE As String = "A1:C100" '<== 按需要改变单元格区域
    
    On Error GoTo ws_exit
    Application.EnableEvents = False
    
    If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
        With Target
            If Len(.Value) = 1 Then
                Me.Cells(.Row - (.Column Mod 3 = 0), .Column Mod 3 + 1).Select
                If Intersect(ActiveCell, Me.Range(WS_RANGE)) Is Nothing Then
                    Me.Range(WS_RANGE).Cells(1, 1).Select
                End If
            End If
        End With
    End If
    
ws_exit:
    Application.EnableEvents = True
End Sub
‘***********************************
说明:该代码中的单元格区域可按您的需要改为合适的单元格区域,但必须是3列。
不限于列的代码如下:
‘***********************************
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range
    Dim Ix As Long, Ad As String
    
    Set Rng = Range("F4:G50") '<== 按需要改变单元格区域
    
    On Error GoTo ws_exit
    Application.EnableEvents = False
    
    If Not Intersect(Target, Rng) Is Nothing Then
       If Len(Target.Value) = 1 Then
         Ad = Target.Address(False, False, xlR1C1, , Rng)
         Ix = Val(Mid(Ad, 3)) * Rng.Columns.Count + Val(Mid(Ad, InStr(Ad, "C") + 2)) + 1
         Rng((Ix Mod Rng.Cells.Count) + 1).Select
       End If
    End If
    
ws_exit:
    Application.EnableEvents = True
End Sub
‘***********************************
说明:上面的代码中,单元格区域可不限于2列。
=====================================================================
问题27:如何将多个工作簿中的工作表一次性合到一个工作簿里面?
解答:关于如何将多个工作簿(xls文件)中的工作表(worksheet)复制到同一个工作簿中的解决。下面的代码可以将某个磁盘目录下的多个xls文件的复制到含有这段代码的xls文件中,而且xls文件可以根据处理worksheet的数量自动的增加xls文件中worksheet的数量。使用时将代码复制到xls文件的宏内,然后运行宏main即可。
代码中运用了filesystemobject对象和excel的range对象的copy方法以及worksheet和workbook对象的add方法。这里就不在赘述,可以在excel vba的帮助中找到。
‘***********************************
Sub Mergesheet(ByVal sPath As String)

   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)  '打开xls文件
        If i_cnt <> 3 Then         '默认的worksheet数量是3,如果超过就自动的增加
          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) '复制worksheet
        i_cnt = i_cnt + 1
        xlbook.Close             '关闭已经打开的xls文件
      End If
    Next
    Set fl = Nothing           '关闭file,folder,filesystemobject对象
    Set fd = Nothing
    Set fs = Nothing
End Sub

Sub main()
  Dim sPath As String
  sPath = InputBox("请输入目录!如C:", "合并目录下xls文件的sheet1")  '显示输入框获取磁盘目录
  If sPath = " " Then Exit Sub
  Mergesheet (sPath)
End Sub
‘***********************************
===================================================================
问题28:关于Excel单元格填充颜色......?
有五种可能的计算结果,比如结果会是1,2,3,4,5,不同的值给单元格填充不同颜色。条件格式最多只能定义三个条件,即只能填充最多三种颜色,不知用什么方法可以填上三种以上的颜色?
解答: 如果所有的结果集合只是在1,2,3,4,5中间,那么写个宏就OK。
假设对于$B这一整列的情况如下:
B1=0或空时,单元格B1无填充颜色;
B1=1 时,给单元格B1填充红色;
B1=2 时,给单元格B1填充蓝色;
B1=3 时,给单元格B1填充绿色;
B1=4 时,给单元格B1填充黄色;
B1=5 时,给单元格B1填充紫色。
B2=0或空时,单元格B2无填充颜色;
B2=1 时,给单元格B2填充红色;
B2=2 时,给单元格B2填充蓝色;
B2=3 时,给单元格B2填充绿色;
B2=4 时,给单元格B2填充黄色;
B2=5 时,给单元格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
‘***********************************
---------------------------------------------------------------------
如果要做到单元格的值改变后填充的颜色自动更新,这个宏该改成怎样?
如果单元格的值是计算得来的,用 worksheet Calculate Event 应该可以。
代码:
‘***********************************
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
    '默认值无填充色
    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
‘***********************************
( 如果单元格的值不是计算得来的,是直接输入的,可以改用 Worksheet Change Event )
---------------------------------------------------------------------
还想问一下,这个宏的功能能否用自定义函数做到?
想用自定义函数的原因:单元格锁定时,自定义函数依然可以正常运行,而宏不行。
这个可以利用 UserInterfaceOnly = TRUE 参数去解决。将 UserInterfaceOnly 参数设置为 True 可以允许通过代码修改,但是不允许通过用户界面修改。默认值为 False,这意味着通过代码和用户界面项都不可以修改受保护的工作表。这个属性设置只适用于当前会话。如果您想让代码可以在任何会话中都可以操作工作表,那么您需要每次工作簿打开的时候添加设置这个属性的代码。
注意红色那段字,由于这个原因,所以加一个宏在 workbook open event 让每次开启档案时去设定UserInterfaceOnly 参数。
代码;
‘***********************************
Private Sub Workbook_Open()
  '如果每个工作表都有不同的密码
  Sheets(1).Protect Password:="secret1", UserInterFaceOnly:=True
  Sheets(2).Protect Password:="secret2", UserInterFaceOnly:=True
'按需要重复
'**如果所有工作表密码相同
   'Dim wSheet As Worksheet
   'For Each wSheet In Worksheets
   '    wSheet.Protect Password:="secret", UserInterFaceOnly:=True
   'Next wSheet
'****
End Sub
‘***********************************
必须了解的一些相关概念(陈希章,微软中文新闻组专家)
一般我们在指定颜色时喜欢用ColorIndex这个属性,通常情况下是没有问题的。
但必须知道的一些概念是:ColorIndex是相对于调色盘中(调色盘有56中颜色)的某个位置的颜色,而调色盘是属于工作簿级的对象,也就是说很有可能这样一种情况就是,在这个工作簿中3代表红色(假设),而到另一个工作簿中却不是。
所以,如果要精确定义颜色,是不推荐用ColorIndex的,往往有些同志在调试程序时的疑惑也在于此(明明在自己电脑上是红色,到用户电脑上就不是了)。
还有两种方法来返回颜色:
1.用Excel常量,如vbred,vbblue,vbgreen等。
2.用RGB函数。
用以上的方法,VBA语句也应相应更改。
例:Target.Offset(0, 1).Interior.ColorIndex = vColor 改成'Target.Offset(0, 1).Interior.Color = vbred 等等。
另从本例而言,建议统一用change事件。
===================================================================
问题29:如何实现在Sheet1中输入后,在Sheet2中相应的单元格中显示?
即,如何实现在
sheet1中输入a1=abc,sheet2中显示a1=abc;
   输入b1=xyz,sheet2中显示a2=xyz;
       再输入a2=123,sheet2中显示a5=123;
             输入b2=qwe, sheet2中显示a6=qwe;
       不停的输入后,sheet2中数字每四行四行不停填充。
解答:
代码说明,这个需求的关键是,需要建立sheet1的行列值与sheet2的行值之间的函数关系,综合看就是一个代数系统内的等差数列的关系。 这个代数式就是:
j=(i-1)*4+t   j代表sheet2的行值,i代表sheet1的行值,t代表sheet1的列值。
所以能够按照所描述的功能的vba代码如下:
‘***********************************
'这是sheet1的worksheet_change事件(触发的条件就是在sheet1输入数据)
Private Sub Worksheet_Change(ByVal Target As Range) 
    If Target.Column > 2 Then   '这里限定最大只可以输入到每行的第2列,否则就不处理
      MsgBox "输错了位置", vbCritical '这里是错误的提示信息
    Exit Sub                         '退出代码的执行
    End If
   '按照sheet1与sheet2行列的特定算法填充数据
   Sheet2.Cells((Target.Row - 1) * 4 + Target.Column, 1) = Target.Value
End Sub
‘***********************************
===================================================================
问题30:如何实现当某一单元格满足非空条件时,输入的数据不能修改?
如果在excel中写如此要求的一个函数:某一单元格满足非空条件时,输入的数据不能修改。就是当我往一个单元格内输入数据后,其中的数据无法再次修改!
解答:代码如下:
‘***********************************
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
‘***********************************
===================================================================
问题31:如何用Vba方法导出Xls文件至Txt文件?
即如何以一定的格式输出Excel文件的数据。
解答:
这是个常见的问题,因为许多不同应用系统之间报送数据时,最好的方法就是报送统一格式的数据文件,而带有特殊分割符号的文本文件应该说是最适用的。
下面的代码将输出的文件改为“文件名”+“Worksheet名”组合的TXT文件。代码的适当说明:生成Txt文件需要使用FileSystemObject对象,关于该对象的说明,可以参阅msdn或vba帮助中的相关内容。这段程序可以在将xls文件中任意的sheet中的内容导出成txt文本文件。
如下就是代码。可以将其复制到任何一个xls文件中。使用时,只要打开某个sheet,然后运行这个宏(菜单内:工具-〉宏-〉运行宏OutPutXlsToTxt),即可将该sheet内的数据导出生成TXT文件,文件名是由Excel文件名和Sheet名组合而成的。
‘***********************************
Sub OutPutXlsToTxt()
  Dim fs, myFile As Object
  Dim i_row, i_col, i_MaxCol As Integer 'xls工作表的行列坐标变量和最大列数变量
  Dim myfileline As String'txtfile的行数据
 
  Set fs = CreateObject("Scripting.FileSystemObject")  '建立filesytemobject
 '通过filesystemobject新建一个和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    '获得整个sheet的最大列数
  If i_MaxCol = 0 Then       '对没有数据的表不做处理并退出程序
    MsgBox "该表无数据,不能导出!", 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))) + "," '生成每行数据
    Next
    myFile.writeline (Mid(myfileline, 1, Len(myfileline) - 1))  '将每行数据写入txtfile
    i_row = i_row + 1
  Loop Until Workbooks(1).ActiveSheet.Cells(i_row, 1) = ""
 
  Set myFile = Nothing
  Set fs = Nothing                   '关闭文件和filesystemobject对象
End Sub
‘***********************************

;