|
VBA程序集
(第8辑)
下面为第8辑VBA程序集的内容，包含程序说明和代码，以及示例文档。
程序35：创建一个固定宽度的文本文件
有时，我们可能想从一个Excel工作表中创建一个固定宽度的文本文件，下面的程序将完成这个功能。您需要传递文件名、工作表和一个以0为起始的固定宽度的数组到该程序中。
程序代码：
‘*********************************************************
Sub CreateFixedWidthFile(strFile As String, ws As Worksheet, s() As Integer)
Dim i As Long, j As Long
Dim strLine As String, strCell As String
'获取一个文件号
Dim fNum As Long
fNum = FreeFile
'打开文本文件
Open strFile For Output As fNum
'从第1行到最后1行进行循环
'您可以使用2以忽略标题行
For i = 1 To ws.Range("a65536").End(xlUp).Row
'开始新行
strLine = ""
'在每个字段间循环
For j = 0 To UBound(s)
'确保我们仅获取与字段长度一致的字符
'(如果长于字段长度则输出错误)
strCell = Left$(ws.Cells(i, j + 1).Value, s(j))
'添加空格符
strLine = strLine & strCell & String$(s(j) - Len(strCell), Chr$(32))
Next j
'写出行
Print #fNum, strLine
Next i
'关闭文件
Close #fNum
End Sub
‘*********************************************************
您可以输入下面的代码调用以上程序进行测试：
‘*********************************************************
Sub CreateFile()
Dim sPath As String
sPath = Application.GetSaveAsFilename("", "Text Files,*.txt")
If LCase$(sPath) = "false" Then Exit Sub
'指定字段宽度
Dim s(6) As Integer
s(0) = 21
s(1) = 9
s(2) = 15
s(3) = 11
s(4) = 12
s(5) = 10
s(6) = 186
'如果使用3列,每列字段宽分别为5,10,15,则使用下面代码
'dim s(2) as Integer
's(0)=5
's(1)=10
's(2)=15
'从活动工作表写入数据
CreateFixedWidthFile sPath, ActiveSheet, s
End Sub
‘*********************************************************
示例文档见 (程序35)创建固定宽度的文本文件.xls。UploadFiles/2006-8/822394004.rar
程序36：生成并分解数组
下面的程序将生成一个数值为1至100的一维数组，并分解成一个多维数组，填充25列和4行单元格区域。
程序代码如下：
‘*********************************************************
Sub SplitArray()
Dim arrBasis(1 To 100) As Integer
Dim arrSplit(1 To 25, 1 To 4) As Integer
Dim iCounter As Integer, iAct As Integer
For iCounter = 1 To 100
arrBasis(iCounter) = iCounter
Next iCounter
For iCounter = 1 To 25
For iAct = 1 To 4
arrSplit(iCounter, iAct) = arrBasis(iCounter * 4 - (4 - iAct))
Next iAct
Next iCounter
Range("A1:D25").Value = arrSplit
End Sub
‘*********************************************************
示例文档见 (程序36)生成并分解数组.xls。UploadFiles/2006-8/822312376.rar
程序37：对给定的每个数据依次列出指定的次数
本程序将对B1至Y3单元格区域中的每个值在一个单独的列中(本例为AA列)依次输入4次。程序代码如下：
‘*********************************************************
Sub ListMultipleTimes()
Application.ScreenUpdating = False
Dim iRow As Integer, iCol As Integer
Dim iCounter As Integer, iAct As Integer
For iRow = 1 To 3
For iCol = 2 To 25
For iAct = 1 To 4
iCounter = iCounter + 1
Cells(iCounter, 27).Value = Cells(iRow, iCol).Value
Next iAct
Next iCol
Next iRow
Application.ScreenUpdating = True
End Sub
‘*********************************************************
示例文档见 (程序37)对给定的数据依次列出指定的次数.xls。UploadFiles/2006-8/822371812.rar
程序38：将前一个值作为批注显示
本示例将会把单元格中的前一个值作为该单元格的批注显示。
如果工作簿共享的话，可能有一些用户会改变工作表中的内容，您可以使用该程序知道在其他用户改变之前的单元格中的值。
工作表Sheet2在本示例中用来临时存放单元格之前的值。
下面的代码放在工作表Sheet1的代码模块中。
‘*********************************************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'复制该单元格的上一个值至另一个工作表
Sheet2.Range(Target.Address) = Target
End Sub
‘*********************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
'只是清除内容,而不清除格式
Target.ClearComments
With Target
'当单元格中的值变化时获得前一个值
.AddComment
.Comment.Visible = False
.Comment.Text Text:="Previous value = " & Sheet2.Range(Target.Address)
End With
End Sub
‘*********************************************************
示例文档见 (程序38)将前一个值作为批注显示.xls。UploadFiles/2006-8/822903165.rar
程序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。UploadFiles/2006-8/822476292.rar
程序40：工作表事件与OnTime方法示例
本示例演示了当您在单元格B1中输入一个值后，如果A1单元格中不为空，那么将在10秒后自动清除单元格A1和B1中的内容。示例代码如下：
在标准模块中输入如下代码：
‘*********************************************************
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。UploadFiles/2006-8/822452067.rar
程序41：阻止工作表自动添加超链接
通常，在工作表中输入一个URL地址或者是邮箱时，Excel会自动将其转化为超链接。下面的代码将阻止工作表自动添加超链接的功能，代码非常简短。
将下面的代码放入工作表Sheet1的代码模块中。
‘*********************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Target.Hyperlinks.Delete
Application.EnableEvents = True
End Sub
‘*********************************************************
示例文档见 (程序41)阻止工作表自动添加超链接。UploadFiles/2006-8/822353410.rar
程序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。UploadFiles/2006-8/822669541.rar
程序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。UploadFiles/2006-8/822413065.rar
程序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。UploadFiles/2006-8/822786710.rar
程序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。UploadFiles/2006-8/822138311.rar
By fanjy in 2006-8-22
|