ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[分享]ExcelVBA程序集汇总(连续更新中......)

  [复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2006-8-14 06:43 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

程序39:删除对其它工作表或工作簿的链接

本程序将删除您所选择的单元格区域的单元格中对其它工作表或工作簿的链接,但不清除单元格中的值。

有时,您可能不想再使工作表中有到其它工作表或工作簿的链接,但要保留工作表中已有的值;有时,您可能想删除工作表中的部分链接,但保留其它的链接。在这些情况下,您可以使用本程序清除您想删除的链接但保留单元格中的值。

程序代码:

‘*********************************************************

Sub DeleteLinks_Selection()

      Dim Cell As Range, FirstAddress As String, Temp As String

      '删除所选单元格中的链接

      Application.ScreenUpdating = False

      With Selection

            Set Cell = .Find("=*!", LookIn:=xlFormulas, searchorder:=xlByRows, _

                            LookAt:=xlPart, MatchCase:=True)

            On Error GoTo Finish

            FirstAddress = Cell.Address

            Do

                  Temp = Cell

                  Cell.ClearContents

                  Cell = Temp

                  Set Cell = .FindNext(Cell)

            Loop Until Cell Is Nothing Or Cell.Address = FirstAddress

      End With

Finish:

End Sub

‘*********************************************************

示例文档见 (程序39)删除所选单元格中的链接.xls

 

KOlzRh7T.rar (6.99 KB, 下载次数: 225)

TA的精华主题

TA的得分主题

 楼主| 发表于 2006-8-14 13:14 | 显示全部楼层

程序40:工作表事件与OnTime方法示例

本示例演示了当您在单元格B1中输入一个值后,如果A1单元格中不为空,那么将在10秒后自动清除单元格A1B1中的内容。示例代码如下:

在标准模块中输入如下代码:

‘*********************************************************

Sub DeleteContents()

   Worksheets("Sheet1").Range("A1:B1").ClearContents

End Sub

‘*********************************************************

Sub MyEntry()

   Range("B1").Value = "Goodbye"

End Sub

‘*********************************************************

在工作表sheet1代码模块中输入如下代码:

‘*********************************************************

Private Sub Worksheet_Change(ByVal Target As Range)

   If Target.Address <> "$B$1" Then Exit Sub

   If IsEmpty(Target) Or IsEmpty(Target.Offset(0, -1)) Then Exit Sub

   Application.OnTime Now + TimeSerial(0, 0, 10), "DeleteContents"

End Sub

‘*********************************************************

示例文档见   (程序40)定时清除单元格内容.xls

mhesFLGJ.rar (6.74 KB, 下载次数: 240)


[此贴子已经被作者于2006-8-14 13:15:51编辑过]

TA的精华主题

TA的得分主题

发表于 2006-8-15 02:52 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2006-8-15 17:34 | 显示全部楼层

程序41:阻止工作表自动添加超链接

通常,在工作表中输入一个URL地址或者是邮箱时,Excel会自动将其转化为超链接。下面的代码将阻止工作表自动添加超链接的功能,代码非常简短。

将下面的代码放入工作表Sheet1的代码模块中。

‘*********************************************************

Private Sub Worksheet_Change(ByVal Target As Range)

   Application.EnableEvents = False

   Target.Hyperlinks.Delete

   Application.EnableEvents = True

End Sub

‘*********************************************************

示例文档见 (程序41)阻止工作表自动添加超链接。

  GloAtXjn.rar (6.54 KB, 下载次数: 206)

TA的精华主题

TA的得分主题

 楼主| 发表于 2006-8-16 14:33 | 显示全部楼层

程序42:重新排列数据

本示例对工作表列A至列C中的数据进行重新排列到相应的字段中。示例代码如下:

‘*********************************************************

Sub ReOrder()

   Dim iRowL As Integer, iRow As Integer

   Columns("A:B").Insert

   iRowL = Cells(Rows.Count, 3).End(xlUp).Row

   For iRow = iRowL To 1 Step -1

      If IsEmpty(Cells(iRow, 5)) Then

         Range(Cells(iRow + 1, 1), Cells(iRow + 1 + _

            WorksheetFunction.CountA(Cells(iRow, 3) _

            .CurrentRegion.Columns(1)) - 2, 2)).Value = _

            Range(Cells(iRow, 3), Cells(iRow, 4)).Value

         Rows(iRow).Delete

         iRow = iRow - 1

      End If

   Next iRow

End Sub

‘*********************************************************

示例文档见 (程序42)重新排列数据.xls

XufzmrCk.rar (6.85 KB, 下载次数: 315)

TA的精华主题

TA的得分主题

发表于 2006-8-16 14:36 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2006-8-16 19:02 | 显示全部楼层

程序43:在VBA中应用Match函数

本示例将工作表Sheet1中的A列的数字用相对应的名字取代,其中名字存储在工作表Sheet2中,在程序代码中使用了Match函数。注意,在运行程序时,应使工作表Sheet1为当前工作表。

程序代码如下:

‘*********************************************************

Sub NumbersToNames()

   Dim var As Variant

   Dim iRow As Integer

   iRow = 2

   Do Until IsEmpty(Cells(iRow, 1))

      var = Application.Match(Cells(iRow, 1).Value, _

         Worksheets("Sheet2").Columns(2), 0)

      If Not IsError(var) Then

         Cells(iRow, 1).Value = _

            Worksheets("Sheet2").Cells(var, 1).Value

      End If

      iRow = iRow + 1

   Loop

End Sub

‘*********************************************************

示例文档见 (程序43)VBA中应用Match函数.xls

wPEWWImv.rar (7.16 KB, 下载次数: 280)

TA的精华主题

TA的得分主题

发表于 2006-8-17 20:22 | 显示全部楼层
虽然看不懂,但估计肯定是好东西,先下载再说!以后再看!

TA的精华主题

TA的得分主题

 楼主| 发表于 2006-8-21 13:40 | 显示全部楼层

程序44:对工作表进行排序

有时,如果您要处理带有多个工作表(工作表和图表工作表)的工作簿,则您可能想按字母顺序排列工作表。

对工作表进行排序的基本代码是Move方法,其语法是:

    SheetsObject.Move(Before,After)

当然,为了有效地使用该方法,我们需要工作表名称的排序列表。这可以新建一个临时工作表来解决。

下一步,在VBE中插入包含实现这个功能的代码模块。模块中包括两个过程:第一个过程验证用户是否真的想排序工作表,如果想排序工作表的话,调用第二个过程去完成该项工作。第一个过程代码如下:

‘********************************************************************

Sub SortSheets()

  If MsgBox("您想对该工作簿中的工作表进行排序吗?", _

    vbOKCancel + vbQuestion, "排序工作表") = vbOK Then

      SortAllSheets

  End If

End Sub

‘********************************************************************

产生动作的过程代码如下。该过程首先在数组中收集工作表的名称,接着在新的工作表中放置该数组,然后使用Sort方法对这些名称排序。接着,用排序好的数据重新填充数组。最后,使用Move方法重新排列这些工作表。

‘********************************************************************

Sub SortAllSheets()

  '排序工作表

  Dim wb As Workbook

  Dim ws As Worksheet

  Dim rng As Range, i As Integer

  Dim cSheets As Integer

  Dim sSheets() As String

 

  Set wb = ActiveWorkbook

 

  '获取数组实际大小

  cSheets = wb.Sheets.Count

  ReDim sSheets(1 To cSheets)

 

  '用工作表名填充数组

  For i = 1 To cSheets

    sSheets(i) = wb.Sheets(i).Name

  Next

 

  '创建新的工作表并在其第一列放置名称

  Set ws = wb.Worksheets.Add

  For i = 1 To cSheets

    ws.Cells(i, 1).Value = sSheets(i)

  Next

 

  '对列排序

  ws.Columns(1).Sort Key1:=ws.Columns(1), Order1:=xlAscending

 

  '重新填充数组

  For i = 1 To cSheets

    sSheets(i) = ws.Cells(i, 1).Value

  Next

 

  '删除临时工作表

  Application.DisplayAlerts = False

  ws.Delete

  Application.DisplayAlerts = True

 

  '通过移动每个工作表到最后来重新排列工作表

  For i = 1 To cSheets

    wb.Sheets(sSheets(i)).Move after:=wb.Sheets(cSheets)

  Next

 

 End Sub

‘********************************************************************

示例文档见 (程序44)对工作表进行排序.xls。

TA的精华主题

TA的得分主题

 楼主| 发表于 2006-8-22 13:18 | 显示全部楼层

程序45:从筛选后的数据中创建数组

本示例将演示如何从筛选后的数据中创建一个数组,并显示数据。代码如下:

‘********************************************************************

Sub FilterIndex()

   Dim rng As Range

   Dim arr As Variant

   Dim iRow As Integer, iCol As Integer

   Dim iRowC As Integer, iColC As Integer

   Application.ScreenUpdating = False

   Set rng = Range("A1").CurrentRegion _

      .SpecialCells(xlCellTypeVisible)

   '添加临时工作簿

   Workbooks.Add

   rng.Copy
    Range("A1")

   Rows(1).Delete

   arr = Range("A1").CurrentRegion

   With Range("A1").CurrentRegion

      iRowC = .Rows.Count

      iColC = .Columns.Count

   End With

   '删除临时工作簿

   ActiveWorkbook.Close savechanges:=False

   For iRow = 1 To iRowC

      For iCol = 1 To iColC

         MsgBox arr(iRow, iCol)

      Next iCol

   Next iRow

   Application.ScreenUpdating = True

End Sub

‘********************************************************************

示例文档见
   (
程序45)从筛选后的数据中生成数组.xls

 

hn2nWX5N.rar (7.94 KB, 下载次数: 261)
[此贴子已经被作者于2006-8-22 13:18:58编辑过]
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 18:02 , Processed in 0.060887 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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