ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 46435|回复: 123

[分享] 非常好的VBA编程问答

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2010-8-16 16:37 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:开发帮助和教程
希望更多EH友分享
为了方便更多EH友下载,特把35楼整理的附件上传到一楼,感谢33楼整理!
别人整理的的VBA,在这里借花献佛了!在这里感谢原创者
VBA编程问答
在学习ExcelVBA编程的过程中,经常会遇到一些问题,有些可能是新碰到的,有些则是以前已遇到过但暂时忘掉了解决办法的,VBA编程问答将把我所收集到的问题和自已所遇到的问题及解决办法进行归纳整理,以方便查阅和参考。
在下面的内容中,有大量的程序代码,并附有简单的说明,您可以将它们输入或复制到VBE编辑器中进行调试,也可以将它们进行适当的调整和修改后应用到自已的程序中。有些问答提供了参考示例,您可以直接下载后处理。

问题1:如何传递参数到OnTime方法和OnAction属性所调用的宏程序中?
问题2:如何禁用用户窗体的关闭按钮?
问题3:可以撤销宏所执行的操作吗?
问题4:如何将同一文件夹中的多个文本文件读入到工作簿中?
问题5:如何使用VBA删除所有的空工作表?
问题6:如何获取计算机上可供使用的打印机列表?
问题7:如何基于某个单元格更新其它单元格的日期?
问题8:如何编写一个宏程序运行另一个宏程序特定的次数?
问题9:如何在一个组合框中列出所有工作表中单元格D3中的值?
问题10:如何使工作表中的文本闪烁?
问题11:如何将工作簿中其它工作表名导入到指定的工作表中?
问题12:如何在单元格中快速输入带秒的时间?
问题14:如何确定一列中带有数据的最后一个单元格?
问题15:如何将一个组合框中的项目筛选至另一个组合框中?(不使用组合框)
问题16:如何将一个组合框中的项目筛选至另一个组合框中?(使用组合框)
问题17:如何允许用户去选择一个文件夹或者目录?
问题18:如何查找应用工作表公式后出现错误的单元格?
问题19:如何查找工作表中的最后一行?
问题20:如何定位某个特定的单元格为屏幕左上角的单元格?
问题21:如何添加自定义工具条?
问题22:在执行Application.Quit命令后,如何避免出现保存警告信息框?
问题23:如何确定单元格背景颜色的名称或者索引号?
问题24:如何查找两个值之间的值?
问题25:如何在一个单元格区域获取两个给定数值之间的最大数值?
问题26:如何实现单元格在指定区域内自动跳转?
问题27:如何将多个工作簿中的工作表一次性合到一个工作簿里面?
问题28:关于Excel单元格填充颜色......?
问题29:如何实现在Sheet1中输入后,在Sheet2中相应的单元格中显示?
问题30:如何实现当某一单元格满足非空条件时,输入的数据不能修改?
问题31:如何用Vba方法导出Xls文件至Txt文件?
问题32:如何删除工作簿中的所有链接?
问题33:如何实现工程不可查看?
问题34:如何判断并根据条件删除行?
问题35:如何在不同的工作表之间进行复制?
问题36:如何在打开工作簿时自动运行宏?
问题37:如何在指定的时间或指定的间隔运行宏?
问题38:如何从Excel中发送E-Mail?
问题39:如何删除重复值?
问题40:如何获取命名单元格区域的地址?

[ 本帖最后由 df888888 于 2011-5-25 10:59 编辑 ]

非常好的VBA编程问答.rar

41.72 KB, 下载次数: 1579

点评

知识树内容索引:问题23的代码颜色枚举不全,见106楼  发表于 2013-10-10 00:21

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-8-16 16:38 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
问题1:当OnTime方法或OnAction属性中设置的所要运行的宏带有参数时,如何传递参数到这些宏程序中?即传递参数到OnTime方法和OnAction属性所调用的宏程序中。
解答:
因为运用Application.OnTime或Object.OnAction调用宏程序的语法基本相似,因此,下面介绍的OnTime方法所使用的语法同样适用于OnAction属性。
为了便于理解,以下介绍均使用一段相似的代码,只不过传递给所调用宏程序MyProcedure的参数不同而已,以此来讲解传递给宏程序不同参数的方法。例如,下面的代码将使MyProcedure宏程序在从现在起的2秒后运行:
Application.OnTime Now + TimeValue("00:00:02"), "MyProcedure"
子问题1:假设MyProcedure宏程序接受参数,如何传递参数到该宏程序中?有下面几种情形:
(1)所调用的宏程序接受一个参数
如果是在正常代码过程中传递参数给宏程序,可以使用" MyProcedure (42)",其中“42”为传递给MyProcedure程序的参数。但如果这样的传递参数方法用在OnTime方法中,该程序将不会运行。
正确的语法是外层为双引号,内层再加上一组单引号,里面是程序名和程序所接受的参数。如下所示:
'MyProcedure宏程序接受一个数值参数
Application.OnTime Now + TimeValue("00:00:02"), "' MyProcedure 42'"
(2)所调用的宏程序接受多个参数
如果所调用的宏程序接受几个参数,那么在这些参数之间应该用逗号分隔。如下所示:
'MyProcedure宏程序接受两个数值参数
Application.OnTime Now + TimeValue("00:00:02"), "'MyProcedure 42, 13'"
(3)所调用的宏程序接受字符串参数
如果所调用的宏程序所接受的参数是字符串,因为字符串已经带有一对双引号,因此应该将字符串包含在双层双引号中,即字符串参数周围有两对双引号。如下所示:
'MyProcedure宏程序接受一个字符串Hello!作为其参数
Application.OnTime Now + TimeValue("00:00:02"), "'MyProcedure ""Hello!""'"
子问题2:当MyProcedure宏程序所接受的参数是变量,如何传递参数到该宏程序中?
(1)该变量为局部变量,用如下所示的方式。
'MyProcedure宏程序接受一个字符串变量strText参数,该变量为局部变量
strText = "Hello!"
Application.OnTime Now + TimeValue("00:00:02"), "'MyProcedure """ & strText & """'"
(2)该变量为全局变量,用如下所示的方式,即不必加双层双引号。
'MyProcedure宏程序接受一个字符串变量g_strText参数,该变量必须声明为公有的
g_strText = "Hello!"
Application.OnTime Now + TimeValue("00:00:02"), "'MyProcedure g_strText'"
注意,在这种情况下变量必须声明为公共变量,否则MyProcedure宏程序将不能找到该变量参数。
=======================================================
问题2:如何禁用用户窗体的关闭按钮?
解答:您可能不想用户在单击窗体右上角的X图标后关闭窗体,您可以在用户窗体代码模块中将UserForm_QueryClose过程的Cancel参数值设置为True,此时虽然X图标仍然存在,但当您单击它时已不起作用,因此可以防止用户通过单击该图标按钮来关闭用户窗体。例如,下面的示例提示用户只能通过单击用户窗体上的“确定”按钮来关闭该用户窗体。您可以在VBE编辑器中插入一个用户窗体,并在用户窗体上放置一个名为“Ok”的按钮,在用户窗体代码模块中输入下面的代码进行调试。
‘**************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  ‘CloseMode参数表明事件发生的原因
‘若其值等于vbFormControlMenu则意味着用户单击了X图标按钮
If CloseMode = vbFormControlMenu Then
    MsgBox "请单击""确定""按钮关闭本窗体"
    Cancel = True
  End If
End Sub
‘**************************************************
Private Sub Ok_Click()
  Unload UserForm1
End Sub
=======================================================
问题3:可以撤销宏所执行的操作吗?
解答:可以,但不能通过Excel内置的功能自动实现。您可以使用VBA代码记录下运行宏程序前单元格或单元格区域原先的内容,在“撤销”命令中调用以恢复程序运行前的状态。
您可以使用Application对象的OnUndo方法作为宏程序结束前的最后一个代码,该方法允许您指定出现在“撤销”菜单项中的文本以及点击该文本后所运行的过程。如下面的代码所示:
Application.Onundo “撤销最后一个宏”,”恢复宏程序”
为说明上述方法,下面列出了一个完整的示例。示例的完整代码以及代码说明如下:
‘**************************************************
Type RangeCellInfo '自定义类型存储宏运行所作出的改变
    CellContent As Variant
    CellAddress As String
End Type
Public OrgWB As Workbook
Public OrgWS As Worksheet
Public OrgCells() As RangeCellInfo
‘**************************************************
Sub EditRange()
  ' 在所有被选取的单元格中插入X
  Dim i As Integer, cl As Range
  If TypeName(Selection) <> "Range" Then Exit Sub
  Application.ScreenUpdating = False
  ReDim OrgCells(Selection.Count)
  Set OrgWB = ActiveWorkbook
  Set OrgWS = ActiveSheet
  i = 1
  ‘记录下宏程序对工作表作出改变前的状态
  For Each cl In Selection
    OrgCells(i).CellContent = cl.Formula
    OrgCells(i).CellAddress = cl.Address
    i = i + 1
  Next cl
  ‘在所选单元格中填允X
  Selection.Formula = "X"
  ‘指定在“撤销”菜单项中的文字及选择该命令时所执行的宏程序
  Application.OnUndo "撤销最后运行的宏过程操作", "UndoEditRange"
End Sub
‘**************************************************
‘恢复工作表原先的状态
Sub UndoEditRange()
  Dim i As Integer
  Application.ScreenUpdating = False
  On Error GoTo NoWBorWS
  OrgWB.Activate
  OrgWS.Activate
  On Error GoTo 0
  '恢复宏运行所作的改变
  For i = 1 To UBound(OrgCells)
      Range(OrgCells(i).CellAddress).Formula = OrgCells(i).CellContent
  Next i
  Set OrgWB = Nothing
  Set OrgWS = Nothing
  Erase OrgCells
NoWBorWS:
End Sub
示例文档见撤销宏示例.xls。UploadFiles/2006-8/81836932.rar
=======================================================
问题4:如何将同一文件夹中的多个文本文件读入到工作簿中?
解答:通常,我们所看到的例子都是在工作簿中读入一个文本文件中的内容。假设有几个文本文件,我们把它们放在与工作簿相同的文件夹中,那么,现在如何在该工作簿中一次性读取这几个文本文件的内容。下面的程序演示了上述过程,示例工作簿附后,其中源数据引用了lichaobin网友在他的提问贴中所附的数据。
分两种情况:
(一)所读入的文本文件总行数小于65536行,您可以使用以下代码。
‘**************************************************
Sub Sample1()
    Dim n As Long, a(), ff As Integer, txt As String, myDir As String, x
    Dim myF As String, i As Long
    myDir = ThisWorkbook.Path & Application.PathSeparator
    myF = Dir(myDir & "*.txt")
    Do While myF <> ""
        ff = FreeFile
        Open myDir & myF For Input As #ff
        Do While Not EOF(ff)
            Line Input #ff, txt
            x = Split(txt, "|")
            n = n + 1
            ReDim Preserve a(1 To n)
            a(n) = x
        Loop
        Close #ff
        myF = Dir()
    Loop
    Cells.Clear
    With ThisWorkbook.Worksheets("Sheet1").Range("a1")
        For i = 1 To UBound(a)
            .Offset(i - 1).Resize(, UBound(a(i)) + 1) = a(i)
        Next
    End With
End Sub
‘**************************************************
(二)所读入的文本文件总行数大于65536行,您可以使用以下代码。其中使用了一个变量t和一个判断语句,当多于65536行时,将剩下的数据写入另一工作表中。
Sub Sample2()
    Dim n As Long, a(), ff As Integer, txt As String, myDir As String, x
    Dim myF As String, i As Long, t As Integer
    t = 1
    myDir = ThisWorkbook.Path & Application.PathSeparator
    myF = Dir(myDir & "*.txt")
    Do While myF <> ""
        ff = FreeFile
        Open myDir & myF For Input As #ff
        Do While Not EOF(ff)
            Line Input #ff, txt
            x = Split(txt, "|")
            n = n + 1
            ReDim Preserve a(1 To n)
            a(n) = x
            If n = 65536 Then
                With ThisWorkbook.Sheets(t).Range("a1")
                    For i = 1 To UBound(a)
                        .Offset(i - 1).Resize(, UBound(a(i)) + 1) = a(i)
                    Next
                End With
                n = 0: Erase a: t = t + 1
            End If
        Loop
            Close #ff
            myF = Dir()
    Loop
        If n > 0 Then
            With ThisWorkbook.Sheets(t).Range("a1")
                For i = 1 To UBound(a)
                    .Offset(i - 1).Resize(, UBound(a(i)) + 1) = a(i)
                Next
            End With
        End If
End Sub
示例文档见读取多个文本文件.rar。UploadFiles/2006-8/81152126.rar
=======================================================
问题5:如何使用VBA删除所有的空工作表?
解答:可以分两种情形来对待。
(一)如果您想删除同一工作簿中的所有空工作表,可以使用下面的两个程序中的其中一个:
‘**************************************************
Sub test1()
Dim ws As Worksheet
  Application.DisplayAlerts = False
  For Each ws In ActiveWorkbook.Worksheets
    ws.Activate
    If ActiveWorkbook.Worksheets.Count > 1 Then
      If IsEmpty(ActiveSheet.UsedRange) Then
          ws.Delete
      End If
     End If
   Next ws
   Application.DisplayAlerts = True
End Sub
‘**************************************************
Sub test2()
Dim ws As Worksheet
On Error GoTo Handdle
  Application.DisplayAlerts = False
  For Each ws In ActiveWorkbook.Worksheets
     ws.Activate
     With ws
       If Application.CountA(.Cells) = 0 Then
         .Delete
       End If
     End With
   Next ws
Handdle:
   Application.DisplayAlerts = True
End Sub
(二)如果您想删除已打开的工作簿中的所有空工作表,可使用下面的程序:
‘**************************************************
Sub test()
Dim ws As Worksheet
Dim wb As Workbook
  Application.DisplayAlerts = False
  For Each wb In Workbooks
    wb.Activate
    For Each ws In ActiveWorkbook.Worksheets
      ws.Activate
      If ActiveWorkbook.Worksheets.Count > 1 Then
        If IsEmpty(ActiveSheet.UsedRange) Then
           ws.Delete
        End If
      End If
    Next ws
  Next wb
  Application.DisplayAlerts = True
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-8-16 16:39 | 显示全部楼层
问题6:如何获取计算机上可供使用的打印机列表?
解答:您可能有时想获取您的计算机上可供使用的打印机列表,然后从中选择打印机输出。最简单的方法是,您可以在代码中添加下面的语句:
Application.Dialogs(xlDialogPrint).Show
=======================================================
问题7:如何基于某个单元格更新其它单元格的日期?
例如:我需要做的一个例行工作是依赖于两个特定单元格的内容添加一些日期到另一个单元格。例如,在单元格J2中有W(代表每周)或者B(代表Bi周)或者M(代表每月),单元格N2中的内容为一个可更新的日期,如果J2中包含一个W我需要在单元格L2中添加7天,或者如果J2中包含一个B我需要在单元格L2中添加14天,或者如果J2中包含一个M则在单元格L2中添加30天,……在单元格J2中包含的信息W,B,或M决定计算的天数,单元格N2中包含原先约定的日期作为开始计算的日期,单元格L2中的这个日期基于上面两个单元格的日期更新。
解答:可以粘贴下面的两个程序之一到工作表代码模块中。
(一)区分大小写,您必须在工作表中输入大写的字母W、B或M。
‘**************************************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("J2").Text = "W" Then
Range("L2") = Range("N2").Value + 7
ElseIf Range("J2").Text = "B" Then
Range("L2") = Range("N2").Value + 14
ElseIf Range("J2").Text = "M" Then
Range("L2") = Range("N2").Value + 30
End If
End Sub
(二)不区分大小写,并使用了Select Case选择语句。
‘**************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$N$2" Or Target.Address = "$J$2" Then
Dim iDays As Byte
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
Select Case UCase(Range("J2").Value)
        Case "W"
           iDays = 7
        Case "B"
           iDays = 14
        Case "M"
           iDays = 30
End Select
Range("L2").Value = Range("N2").Value + iDays
Application.EnableEvents = True
Exit Sub
ERRORHANDLER:
Application.EnableEvents = True
End If
End Sub
=======================================================
问题8:如何编写一个宏程序运行另一个宏程序特定的次数?
解答:可以用一个简单的循环来实现。
‘**************************************************
Sub FirstMacro()
Dim RunCount as Long
Const RunMax As Long=10 ‘定义要运行的次数
For RunCount =1 To RunMax
    Call SecondMacro ‘调用要运行的宏程序
Next
End Sub
=========================================================
问题9:如何在一个组合框中列出所有工作表中单元格D3中的值?
解答:假设用户窗体中有一个名为ComboBox1的组合框,您可在用户窗体中添加以下代码,当用户窗体被激活时,在组合框中将显示出所有工作表中单元格D3的值。
‘**************************************************
Private Sub UserForm_Activate()
  Dim ws As Worksheet
  For Each ws In Worksheets
    ComboBox1.AddItem ws.Range("D3").Text
  Next ws
End Sub
=======================================================
问题10:如何使工作表中的文本闪烁?
解答:为了使文本闪烁,您需要周期性地执行一个程序来变换文本的前景色,OnTime方法可以用于周期性地运行一个程序。
‘**************************************************
Public RunWhen As Double
Sub StartBlink()
If Range("A1").Font.ColorIndex = 2 Then
        Range("A1").Font.ColorIndex = xlColorIndexAutomatic
    Else
        Range("A1").Font.ColorIndex = 2
End If
RunWhen = Now + TimeSerial(0, 0, 1)
Application.OnTime RunWhen, "StartBlink", , True
End Sub
‘**************************************************
Sub StopBlink()
Range("A1").Font.ColorIndex = xlColorIndexAutomatic
Application.OnTime RunWhen, "StartBlink", , False
End Sub
在上面的这些程序中,您可以改变参数A1为您想要使文本闪烁的单元格或单元格区域。在工作簿打开时,您需要初始化这个程序,因此,您可以放置下面的代码到ThisWorkbook代码模块中。
‘**************************************************
Private Sub Workbook_Open()
StartBlink
End Sub
当工作簿关闭时,您需要取消OnTime事件,因此,您需要放置下面的代码到ThisWorkbook代码模块中。
‘**************************************************
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopBlink
End Sub
=======================================================

[ 本帖最后由 df888888 于 2011-1-9 23:26 编辑 ]

TA的精华主题

TA的得分主题

发表于 2010-8-16 16:39 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
谢谢楼主,学习了

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-8-16 16:39 | 显示全部楼层
问题11:如何将工作簿中其它工作表名导入到指定的工作表中?
解答:本问题即将工作簿中除指定的工作表(如名为Name的工作表)外的其它的工作表名导入到指定的工作表中(即Name工作表中)。您可以使用下面的代码。
‘**************************************************
Sub Test()
  Dim ws As Worksheet
  Dim i As Long, j As Long
  Worksheets("Name").Range("A:A").Clear
i = Worksheets("Name").Range("A65536").End(xlUp).Row
  For Each ws In Worksheets
     If ws.Name <> "Name" Then
        Worksheets("Name").Cells(i, 1) = ws.Name
        i = Worksheets("Name").Range("A65536").End(xlUp).Row + 1
      End If
  Next ws
End Sub
=======================================================
问题12:如何在单元格中快速输入带秒的时间?
解答:一般,在Excel中快速输入日期和时间时,可使用快捷键,即按Ctrl+:组合键将快速在单元格中输入当前日期,按Ctrl+Shift+:组合键将快速在单元格中输入当前时间,但所显示的时间为“小时:分钟”格式,不会显示秒。如果您想显示“小时:分钟:秒”这样的格式的话,可以使用Onkey方法修改快捷键的缺省设置,如下所示,运行“设置快捷键”代码即可。
‘**************************************************
Sub 设置快捷键()
    Application.OnKey "+^:", "输入时间"
End Sub
‘**************************************************
Sub 恢复快捷键()
    Application.OnKey "+^:"
End Sub
‘**************************************************
Sub 输入时间()
    With ActiveCell
    .Value = Time()
      .NumberFormat = "hh:mm:ss"
    End With
End Sub
如果您想恢复快捷键的缺省设置,运行“恢复快捷键”过程。
=======================================================
问题14:如何确定一列中带有数据的最后一个单元格?
解答:这里编写了一个通用函数,您可以调用,从而返回您指定的列中的最后单元格。
‘***********************************
Function LastRowInColumn(intCol As Integer) As Integer
    On Error GoTo LRICError
    Application.Volatile '确保工作表发生变化时调用该函数
    ‘通用代码Rows.Count表示工作表行数
LastRowInColumn = Cells(Rows.Count, intCol).End(xlUp).Row
ExitFnxn:
    Exit Function
'如果出错,则返回错误值到最后的单元格中
LRICError:
    LastRowInColumn = CVErr(xlErrNA)
    Resume ExitFnxn
End Function
‘***********************************
您可以在工作表中输入以下测试代码对上面的函数进行测试。
‘***********************************
Sub test()
  Dim X As Integer
  ‘指定确定第2列中的最后一个单元格
X = LastRowInColumn(2)
  Debug.Print X
End Sub
‘***********************************
示例文档见(问题14)确定某列中的最后单元格.xls。UploadFiles/2006-8/83708035.rar
=====================================================================
问题15:如何将一个组合框中的项目筛选至另一个组合框中?(不使用组合框)
解答:通过后附的示例工作表来说明。在这个示例中,我们没有真正的使用组合框,实际上使用的是数据有效性选项。
当用户在单元格B1中选择公司时,单元格C1将自动列出有效的值,确保显示该公司中雇员名。但您要输入如下的代码在工作表Sheet1模块中:
‘***********************************
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$B$1" Then
        FilterList
    End If
End Sub
‘***********************************
在标准模块中输入以下代码:
‘***********************************
Sub FilterList()
    Dim strList As String, strCompany As String, strEmployee As String
    On Error GoTo FilterListError
    strCompany = Range("B1").Text
    Select Case strCompany
        Case "Apple"
            strList = "=$F$2:$F$6"
        Case "IBM"
            strList = "=$G$2:$G$4"
        Case "Microsoft"
            strList = "=$H$2:$H$4"
    End Select
   
    With Range("C1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=strList
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = "无效雇员名"
        .InputMessage = ""
        .ErrorMessage = "请从列表中选择一个雇员名"
        .ShowInput = False
        .ShowError = True
    End With                strEmployee = Range("C1").Text
    '移除'='号
    strList = Mid(strList, 2)
   
    '确保当前雇员名是在特定的公司,如果不是,从列表中取该公司的第一个雇员名
    If Not IsTextInList(strEmployee, Range(strList)) Then
        Range("C1") = PickFirstEmployee(Range(strList))
    End If
   
FilterListError:
    Exit Sub
End Sub
‘***********************************
Function IsTextInList(TextToFind As String, R As Range) As Boolean
    Dim FirstRow As Integer, LastRow As Integer, iRow As Integer
    Dim blnFound As Boolean, iCol As Integer
    FirstRow = R.Row
    LastRow = FirstRow + R.Rows.Count - 1
    iCol = R.Column
    blnFound = False
    For iRow = FirstRow To LastRow
        If Cells(iRow, iCol).Text = TextToFind Then
            blnFound = True
            Exit For
        End If
    Next iRow
    IsTextInList = blnFound
End Function
‘***********************************
Function PickFirstEmployee(R As Range) As String
    Dim iRow As Integer, iCol As Integer
    iRow = R.Row
    iCol = R.Column
    PickFirstEmployee = Cells(iRow, iCol).Text
End Function
‘***********************************
===================================================================

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-8-16 16:40 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本楼为重复帖,撤除,谢谢gfs57反馈

[ 本帖最后由 df888888 于 2011-1-9 23:36 编辑 ]

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-8-16 16:41 | 显示全部楼层
问题16:如何将一个组合框中的项目筛选至另一个组合框中?(使用组合框)
解答:通过后附的示例工作表来说明。在这个工作表中,单击按钮会出现一个“组合框链接”用户窗体,在第一个组合框中选择不同的选项,在第二个组合框中的项目相应发生变化。
在VBE编辑器中,设计一个带有两个组合框(名称分别为cboCategory和cboChoices)的用户窗体,并在窗体模块中输入如下代码:
‘***********************************
Sub UpdatecboChoices()
    Select Case cboCategory.Text
        Case "颜色"
            cboChoices.RowSource = "A2:A6"
        Case "交通工具"
            cboChoices.RowSource = "B2:B5"
        Case "大洲"
            cboChoices.RowSource = "C2:C8"
        Case Else
            cboChoices.List = ""
    End Select
    cboChoices.ListIndex = 0
End Sub
‘***********************************
Private Sub cboCategory_Change()
    UpdatecboChoices
End Sub
‘***********************************
Private Sub UserForm_Activate()
    Dim i As Integer
    cboCategory.Clear
    For i = 1 To 3
        cboCategory.AddItem Cells(1, i)
    Next i
    cboCategory.ListIndex = 0
End Sub
‘***********************************
示例文档见(问题16)筛选一个组合框中的值到另一个组合框中.xls。UploadFiles/2006-8/83551438.rar
===================================================================
问题17:如何允许用户去选择一个文件夹或者目录?
解答:下面是运用Windows对话框允许用户选取一个文件夹目录的代码:
‘***********************************
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
‘***********************************
'API声明
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long            Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
‘***********************************
'下面的函数出现让用户选择文件目录的一个窗体
Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, X As Long, i As Integer
            ' 设置根目录为桌面
    bInfo.pidlRoot = 0&
            '设置对话框标题
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "请选择一个文件夹."
    Else
        bInfo.lpszTitle = Msg
    End If
   
'返回的目录类型
    bInfo.ulFlags = &H1
            '显示对话框
    X = SHBrowseForFolder(bInfo)
   
'分析结果
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal X, ByVal path)
    If r Then
          i = InStr(path, Chr$(0))
        GetDirectory = Left(path, i - 1)
    Else
        GetDirectory = ""
    End If
End Function
‘***********************************
示例文档见(问题17)允许选择文件夹目录.xls。UploadFiles/2006-8/83574180.rar
此外,运行下面的代码将允许用户使用Windows对话框选择一个文件:
‘***********************************
Sub test()
  Dim Filename
  Filename = Application.GetOpenFilename()
End Sub
‘***********************************
GetOpenFilename是一个内置的Excel函数,它仅返回一个文件名。您必须采取读取文件的操作。
===================================================================
问题18:如何查找应用工作表公式后出现错误的单元格?
解答:下面是一个很方便使用的程序,用于查找在工作表中应用公式后出现错误值的单元格并选中。
‘***********************************
Sub FindErrors()
‘如果没有在工作表中发现错误,将会产生错误
On Error Goto FEError
ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas, xlErrors).Select
Exit Sub
FEError:
  MsgBox "没有发现错误", , "提示!"
Exit Sub
End Sub
‘***********************************
===================================================================
问题19:如何查找工作表中的最后一行?
解答:下面是一个快速且简单的函数,用于获取工作表中含有数据的最后一行。
‘***********************************
Function GetLastRow(SheetID) As Integer
    Dim LastRow As Integer
    If Application.WorksheetFunction.CountA(Worksheets(SheetID).Cells) = 0 Then
        LastRow = 1
    Else
        LastRow = Worksheets(SheetID).UsedRange.Rows.Count + Worksheets(SheetID).UsedRange.Row
        While Application.WorksheetFunction.CountA(Worksheets(SheetID).Rows(LastRow)) = 0
            LastRow = LastRow - 1
        Wend
    End If
    GetLastRow = LastRow
End Function
‘***********************************
您可以使用简单的语句进行测试,在代码模块中输入如下代码:
‘***********************************
Sub test()
  Dim I As Long
  I=GetLastRow(1)
  Debug.Print i
End Sub
‘***********************************
运行上述过程后,将会在立即窗口中显示当前工作簿中工作表1中最后一行的行号。
===================================================================
问题20:如何定位某个特定的单元格为屏幕左上角的单元格?
解答:可以通过滚动行和滚动列来实现:
‘***********************************
'定位工作表中的单元格M14在屏幕左上角
Sub test()
Worksheets(1).Select
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollColumn = 13
End Sub
‘***********************************
也可以使用以下语句实现:
‘***********************************
'定位工作表中的单元格G10在屏幕左上角
Sub test()
Application.GoTo Range("G10"), True
End Sub
===================================================================

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-8-16 16:42 | 显示全部楼层
问题21:如何添加自定义工具条?
解答:下面是添加自定义工具条的示例代码,运行该代码后将在“标准”工具条的右侧出现一个名为“我的工具条”的自定义工具条,与Excel的内置工具条一样,您可以移动/悬浮它,并且单击工具条里的命令可以执行相应的操作。当然,如果您愿意的话,可以将本示例扩展,添加一些有用的命令在自定义的工具条上,从而扩展Excel的功能。
本示例中,该工具条是临时的,当您关闭工作簿后,它不会保存。您最好在在Workbook_Open事件中调用”AddToolbar”程序,这样当打开该工作簿时,自动添加自定义的工具条。
‘***********************************
Sub AddToolBar()
    Dim cmdbar As CommandBar
    Dim CmdBtn1 As CommandBarButton
    Dim strTBName As String                strTBName = "我的工具条"
   
    '如该工具条已经存在则不再添加
    If CheckForToolbar(strTBName) Then Exit Sub
   
    Set cmdbar = CommandBars.Add(Name:=strTBName, Position:=msoBarTop, Temporary:=True)
    cmdbar.Visible = True
   
    With cmdbar
        '放置该工具条在“标准”工具条的右侧
                    .Left = CommandBars("Standard").Width
        .RowIndex = CommandBars("Standard").RowIndex
        
        Set CmdBtn1 = .Controls.Add(msoControlButton, , , , True)
        With CmdBtn1
            .Style = msoButtonCaption
            .Caption = "我的工具条"
            .TooltipText = "这是一个示例工具条."
            .
        End With
        
    End With
   
    Set cmdbar = Nothing
    Set CmdBtn1 = Nothing
   
End Sub
‘***********************************
Function CheckForToolbar(argName As String) As Boolean
    Dim bar As CommandBar, Result As Boolean
   
    Result = False
   
    For Each bar In CommandBars
        If bar.Name = argName Then
            Result = True
        End If
    Next bar
   
    CheckForToolbar = Result
   
End Function
‘***********************************
Sub HelloWorld()
                MsgBox "Hello World!"
            End Sub
‘***********************************
===================================================================
问题22:在执行Application.Quit命令后,如何避免出现保存警告信息框?
解答:通常当执行Application.Quit语句后,如果在这之前工作簿有变化,都会出现“是否保存对工作簿XXX的修改”的警告框。为了避免出现这个警告框,可以采用以下方法。
1、添加代码指定您是否想保存工作簿所发生的变化,代码如下:
‘***********************************
Workbooks(x).Close Savechanges:=True
‘***********************************
运行上述代码后,将弹出“另存为”对话框。
2、关闭Excel警告信息。这样对工作簿所做的任何改变均不会被保存,等于在警告框中选择“否”按钮。因此,这种方法将会使您对工作簿所做的更改不被保存,建议您在需要避免警告框的地方使用该语句后,立即恢复设置。即:
‘***********************************
Application.DisplayAlerts = False
Workbooks(x).Close
Application.DisplayAlerts = True
‘***********************************
3、使用语句,让Excel觉得工作簿已经被保存过了。
‘***********************************
Workbooks(x).Saved = True
Workbooks(x).Close
‘***********************************
===================================================================
问题23:如何确定单元格背景颜色的名称或者索引号?
解答:下面的自定义函数可用来返回单元格背景颜色索引号或者是颜色名称。
‘***********************************
Function CellColor(rCell As Range, Optional ColorName As Boolean)
  Dim strColor As String, iIndexNum As Integer
              Select Case rCell.Interior.ColorIndex
     Case 1
      strColor = "Black"
      iIndexNum = 1
     Case 53
      strColor = "Brown"
      iIndexNum = 53
     Case 52
      strColor = "Olive Green"
      iIndexNum = 52
     Case 51
      strColor = "Dark Green"
      iIndexNum = 51
     Case 49
      strColor = "Dark Teal"
      iIndexNum = 49
     Case 11
      strColor = "Dark Blue"
      iIndexNum = 11
     Case 55
      strColor = "Indigo"
      iIndexNum = 55
     Case 56
      strColor = "Gray-80%"
      iIndexNum = 56
     Case 9
      strColor = "Dark Red"
      iIndexNum = 9
     Case 46
      strColor = "Orange"
      iIndexNum = 46
     Case 12
      strColor = "Dark Yellow"
      iIndexNum = 12
     Case 10
      strColor = "Green"
      iIndexNum = 10
     Case 14
      strColor = "Teal"
      iIndexNum = 14
     Case 5
      strColor = "Blue"
      iIndexNum = 5
     Case 47
      strColor = "Blue-Gray"
      iIndexNum = 47
     Case 16
      strColor = "Gray-50%"
      iIndexNum = 16
     Case 3
      strColor = "Red"
      iIndexNum = 3
     Case 45
      strColor = "Light Orange"
      iIndexNum = 45
     Case 43
      strColor = "Lime"
      iIndexNum = 43
     Case 50
      strColor = "Sea Green"
      iIndexNum = 50
     Case 42
      strColor = "Aqua"
      iIndexNum = 42
     Case 41
      strColor = "Light Blue"
      iIndexNum = 41
     Case 13
      strColor = "Violet"
      iIndexNum = 13
     Case 48
      strColor = "Gray-40%"
      iIndexNum = 48
     Case 7
      strColor = "Pink"
      iIndexNum = 7
     Case 44
      strColor = "Gold"
      iIndexNum = 44
     Case 6
      strColor = "Yellow"
      iIndexNum = 6
     Case 4
      strColor = "Bright Green"
      iIndexNum = 4
     Case 8
      strColor = "Turqoise"
      iIndexNum = 8
     Case 33
      strColor = "Sky Blue"
      iIndexNum = 33
     Case 54
      strColor = "Plum"
      iIndexNum = 54
     Case 15
      strColor = "Gray-25%"
      iIndexNum = 15
     Case 38
      strColor = "Rose"
      iIndexNum = 38
     Case 40
      strColor = "Tan"
      iIndexNum = 40
     Case 36
      strColor = "Light Yellow"
      iIndexNum = 36
     Case 35
      strColor = "Light Green"
      iIndexNum = 35
     Case 34
      strColor = "Light Turqoise"
      iIndexNum = 34
     Case 37
      strColor = "Pale Blue"
      iIndexNum = 37
     Case 39
      strColor = "Lavendar"
      iIndexNum = 39
     Case 2
      strColor = "White"
      iIndexNum = 2
    Case Else
      strColor = "自定义的颜色或者没有填充颜色."
  End Select
                If ColorName = True Or _
        strColor = "自定义的颜色或者没有填充颜色." Then
        CellColor = strColor
    Else
        CellColor = iIndexNum
    End If
            End Function
‘***********************************
当您在VBE编程器中的标准模块代码窗口中输入上述代码并保存后,该函数将出现在“用户定义”函数列表中,您可以在工作簿中进行测试。例如,如果您将工作表中A1单元格背景色设置为绿色,在A2单元格中输入公式“=CellColor(A1,True)”后,将显示文本“Green”;若输入公式“=CellColor(A1,False)或=CellColor(A1)”,则显示索引号“10”。即该函数的第二个参数设置为“True”,则显示颜色文本;若设置为“False”或省略,则显示颜色索引号。
===================================================================

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-8-16 16:43 | 显示全部楼层
问题24:如何查找两个值之间的值?
解答:在Excel和大多数的MSOffice应用程序中,有一个“查找”功能可用来在一个范围、工作表或工作簿中查找特定的值、或者文本字符串。然而,没有一个用于查找在两个值之间(指定的最大值和最小值)之间第一次出现某个值的位置的功能,我们能使用VBA代码来处理。代码如下:
‘***********************************
Sub GetBetween()
  Dim strNum As String
  Dim lMin As Long, lMax As Long
  Dim rFound As Range, rLookin As Range
  Dim lFound As Long, rStart As Range
  Dim rCcells As Range, rFcells As Range
  Dim lCellCount As Long, lcount As Long
  Dim bNoFind As Boolean              strNum = InputBox("请先输入最大值,然后输入逗号," _
        & "接着输入最大值" & vbNewLine & _
        vbNewLine & "例如: 1,10", "输入最小值和最大值")
        
  If strNum = vbNullString Then Exit Sub
  On Error Resume Next
  lMin = Left(strNum, InStr(1, strNum, ","))
  If Not IsNumeric(lMin) Or lMin = 0 Then
     MsgBox "输入数据错误, 或者最小值不应为零", vbCritical
     Exit Sub
  End If
      
  lMax = Replace(strNum, lMin & ",", "")
  If Not IsNumeric(lMax) Or lMax = 0 Then
     MsgBox "输入数据错误,或者最大值不应为零", vbCritical
     Exit Sub
  End If
        
  If lMax < lMin Then
     MsgBox "最小值大于最大值", vbCritical
     Exit Sub
  End If
         
  If lMin + 1 = lMax Then
     MsgBox "最大值和最小值之间没有范围", vbCritical
     Exit Sub
  End If
         
  If Selection.Cells.Count = 1 Then
     Set rCcells = Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
     Set rFcells = Cells.SpecialCells(xlCellTypeFormulas, xlNumbers)
     Set rStart = Cells(1, 1)
  Else
     Set rCcells = Selection.SpecialCells(xlCellTypeConstants, xlNumbers)
     Set rFcells = Selection.SpecialCells(xlCellTypeFormulas, xlNumbers)
     Set rStart = Selection.Cells(1, 1)
  End If
        
  '缩小查找范围
  If rCcells Is Nothing And rFcells Is Nothing Then
     MsgBox "工作表无数据", vbCritical
     Exit Sub
  ElseIf rCcells Is Nothing Then
     Set rLookin = rFcells.Cells '公式
  ElseIf rFcells Is Nothing Then
     Set rLookin = rCcells.Cells '常量
  Else
     Set rLookin = Application.Union(rFcells, rCcells) '公式和常量
  End If
   
  lCellCount = rLookin.Cells.Count
  Do Until lFound > lMin And lFound < lMax And lFound > 0
     lFound = 0
     Set rStart = rLookin.Cells.Find(What:="*", After:=rStart, LookIn:=xlValues, _
                       LookAt:=xlWhole, SearchOrder:=xlByRows, _
                       SearchDirection:=xlNext, MatchCase:=True)
     lFound = rStart.Value
     lcount = lcount + 1
     If lCellCount = lcount Then
        bNoFind = True
        Exit Do
     End If
  Loop

  rStart.Select
        
  If bNoFind = True Then
     MsgBox "没有数据在" _
     & lMin & " 和 " & lMax & "之间", vbInformation
  End If
  On Error GoTo 0
End Sub
‘***********************************
该代码将以工作表中“查找”功能相同的方式工作,当仅选择一个单元格时,将在所有单元格中查找;当选择一部分单元格时,仅在所选单元格区域中查找,在两个值之间的符合条件的第一个单元格被选中,不包含最小值和最大值本身。注意,本程序代码不会查找零值。
例如,在工作表中有1至10共10个数据,若您要查找3至5之间的数据,运行后在对话框中输入3,5,内容为4的单元格将被选中。
===================================================================
问题25:如何在一个单元格区域获取两个给定数值之间的最大值?
解答:下面的自定义函数将在单元格区域中获取任意两个指定数值之间的最大值。
‘***********************************
Function GetMaxBetween(rCells As Range, MinNum, MaxNum)
  Dim rRange As Range
  Dim vMax
  Dim aryNums()
  Dim i As Integer
              ReDim aryNums(rCells.Count)
  For Each rRange In rCells
    vMax = rRange
    Select Case vMax
      Case MinNum + 0.01 To MaxNum - 0.01
        aryNums(i) = vMax
        i = i + 1
    Case Else
        GetMaxBetween = 0
    End Select
  Next rRange
   
  GetMaxBetween = WorksheetFunction.Max(aryNums)
End Function
‘***********************************
您在VBE编辑器中输入上述代码后,该函数将出现在“用户定义”函数中,您可以在工作表单元格中输入公式进行测试,例如,在单元格C7中输入“=GetMaxBetween(A1:A10,2,9)”回车后将得到单元格区域A1至A10中大于2且小于9的最大值,精度可达到0.01.
===================================================================
问题26:如何实现单元格在指定区域内自动跳转?
例如,在单元格区域A1:C100中,无论何时在其中的某个单元格中输入完一个单个的字符后,自动按规律跳转到下一单元格,即在单元格B1中输完后,跳转到单元格C1,在单元格C1中输入完单个字符后,自动跳转到单元格A2,……
解答:可以在工作表事件中使用下面的代码:
‘***********************************
PrivateSub Worksheet_Change(ByVal Target As Range)
    ConstWS_RANGE As String = "A1:C100" '<==按需要改变单元格区域
   
    On ErrorGoTo ws_exit
   Application.EnableEvents = False
   
    If NotIntersect(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列。
不限于列的代码如下:
‘***********************************
PrivateSub Worksheet_Change(ByVal Target As Range)
    Dim Rng AsRange
    Dim Ix AsLong, Ad As String
   
    Set Rng =Range("F4:G50") '<==按需要改变单元格区域
   
    On ErrorGoTo ws_exit
   Application.EnableEvents = False
   
    If NotIntersect(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列。
=====================================================================

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-8-16 16:44 | 显示全部楼层
问题27:如何将多个工作簿中的工作表一次性合到一个工作簿里面?
解答:关于如何将多个工作簿(xls文件)中的工作表(worksheet)复制到同一个工作簿中的解决。下面的代码可以将某个磁盘目录下的多个xls文件的复制到含有这段代码的xls文件中,而且xls文件可以根据处理worksheet的数量自动的增加xls文件中worksheet的数量。使用时将代码复制到xls文件的宏内,然后运行宏main即可。
代码中运用了filesystemobject对象和excel的range对象的copy方法以及worksheet和workbook对象的add方法。这里就不在赘述,可以在excelvba的帮助中找到。
‘***********************************
SubMergesheet(ByVal sPath As String)   Dim fs, fd, fl AsObject
   Dim xlbook As Workbook
   Dim xlsheet As Worksheet
   Dim i_cnt As Integer
   i_cnt = 1
   Set fs =CreateObject("scripting.filesystemobject") '建立filesystemobject
   If Notfs.FolderExists(sPath) Then
     MsgBox "目录不存在!", vbCritical
     Exit Sub
   End If
    Set fd =fs.getfolder(sPath)  '或取文件夹
   For Each fl Infd.Files       '依此处理文件夹中的文件
     If Right(Trim(fl.Name), 3) = "xls"Then    '只处理xls文件
       Set xlbook = Application.Workbooks.Open(sPath + "\" +fl.Name)  '打开xls文件
       If i_cnt <> 3Then       '默认的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对象
    Setfd = 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填充紫色。
……
代码:
‘***********************************
SubMacro1()
  For i = 1 To 4096 ‘要填充颜色的单元格,可修改为所需要的
   Range("B" + CStr(i)).Select
    Select CaseRange("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
    EndSelect
    With Selection.Interior
     .Pattern = xlSolid
     .PatternColorIndex =xlAutomatic
    EndWith
  Next
End Sub
‘***********************************
---------------------------------------------------------------------
如果要做到单元格的值改变后填充的颜色自动更新,这个宏该改成怎样?
如果单元格的值是计算得来的,用 worksheet Calculate Event应该可以。
代码:
‘***********************************
PrivateSub Worksheet_Calculate()
  Dim vValue As Integer
  Dim vColor As Integer
  Dim cRange As Range
  Dim cell As Range
  For Each cell InIntersect(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
‘***********************************
(如果单元格的值不是计算得来的,是直接输入的,可以改用 WorksheetChange Event )
---------------------------------------------------------------------
还想问一下,这个宏的功能能否用自定义函数做到?
想用自定义函数的原因:单元格锁定时,自定义函数依然可以正常运行,而宏不行。
这个可以利用 UserInterfaceOnly = TRUE 参数去解决。将UserInterfaceOnly 参数设置为 True可以允许通过代码修改,但是不允许通过用户界面修改。默认值为False,这意味着通过代码和用户界面项都不可以修改受保护的工作表。这个属性设置只适用于当前会话。如果您想让代码可以在任何会话中都可以操作工作表,那么您需要每次工作簿打开的时候添加设置这个属性的代码。
注意红色那段字,由于这个原因,所以加一个宏在 workbook open event让每次开启档案时去设定UserInterfaceOnly 参数。
代码;
‘***********************************
PrivateSub Workbook_Open()
'如果每个工作表都有不同的密码
Sheets(1).Protect Password:="secret1",UserInterFaceOnly:=True
  Sheets(2).Protect Password:="secret2",UserInterFaceOnly:=True
'按需要重复
'**如果所有工作表密码相同
   'Dim wSheet As Worksheet
   'For Each wSheet InWorksheets
  '   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 AsRange)
    IfTarget.Column > 2 Then  '这里限定最大只可以输入到每行的第2列,否则就不处理
     MsgBox "输错了位置", vbCritical '这里是错误的提示信息
   ExitSub                        '退出代码的执行
   End If
  '按照sheet1与sheet2行列的特定算法填充数据
   Sheet2.Cells((Target.Row - 1)* 4 + Target.Column, 1) = Target.Value
End Sub
‘***********************************
===================================================================
问题30:如何实现当某一单元格满足非空条件时,输入的数据不能修改?
如果在excel中写如此要求的一个函数:某一单元格满足非空条件时,输入的数据不能修改。就是当我往一个单元格内输入数据后,其中的数据无法再次修改!
解答:代码如下:
‘***********************************
PrivateSub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target <> "" Then
   Target.Locked = True
   ActiveSheet.Protectpassword:="123"
End If
If Target = "" Then
   ActiveSheet.Unprotectpassword:="123"
End If
End Sub
‘***********************************
===================================================================
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 00:30 , Processed in 0.054335 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表