龙网论坛

 找回密码
 注册
查看: 5864|回复: 0
收起左侧

[办公] EXCEL VBA代码集

[复制链接]
发表于 2010-6-18 09:12 | 显示全部楼层 |阅读模式
求单元格公式变为字符串的方法
http://post.baidu.com/f?kz=98837800
我需要检查一个有50个工作表的工作簿的公式,每个工作表的公式基本一样。
如何完成?
我考虑了一个方法,就是把把工作表里的公式转变为字符串,然后就可以让程序与一个已定义好的字符串表格向比较就可以了。但我不是到如何让这样大量的公式变为字符串,请各位帮忙
解答:
在新工作表中列出当前工作表的公式:
Sub Text()
Dim XR As Range, YR As Range
Set XR = Cells.SpecialCells(xlCellTypeFormulas, 23)
Sheets.Add
Cells.NumberFormatLocal = "@"
For Each YR In XR
Cells(YR.Row, YR.Column) = YR.FormulaLocal
Next
End Sub
知识点:
利用SpecialCells的xlCellTypeFormulas(含有公式的单元格)选择出包含公式的单元格。
一个提取中文/英文/数字的自定义函数:
http://post.baidu.com/f?kz=98643915
srg为所要提取的字符串,可以直接输入单元格如A1,n为1、2、0时分别提取汉字、英文字母、数字。
Function MyGet(Srg As String, Optional n As Integer = False, Optional start_num As Integer = 1)
     Dim i As Integer
     Dim s, MyString As String
     Dim Bol As Boolean      
     For i = start_num To Len(Srg)
         s = Mid(Srg, i, 1)
         If n = 1 Then
             Bol = Asc(s) < 0
         ElseIf n = 2 Then
             Bol = s Like "[a-z,A-Z]"
         ElseIf n = 0 Then
             Bol = s Like "#"
         End If
         If Bol Then MyString = MyString & s
     Next      
     MyGet = IIf(n = 1 Or n = 2, MyString, Val(MyString))      
End Function
知识点:利用Like中判断数字/字母和利用ASC来判断中文。
不用逐份复制怎样才能把多份工作表集合为一份呢?
http://post.baidu.com/f?kz=96717211
因为工作表太多,所以逐份复制很麻烦,不知道有没有更好的办法一次完成呢?
解答:
Sub HB()
Dim XS As Worksheet
Set XS = Sheets.Add(Before:=Sheets(1))
For i = 2 To ActiveWorkbook.Sheets.Count
Sheets(i).Select
If WorksheetFunction.CountA(ActiveSheet.UsedRange) = 0 Then
XS.Select
Else
ActiveSheet.UsedRange.Copy
XS.Select
ActiveSheet.Paste
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1).Select
End If
Next
End Sub
知识点:其实没有什么,就是利用循环来重复手工的复制操作,而用UsedRange(使用区域)加1来获得粘贴的位置。
怎样是单元格的双击事件无效?
http://post.baidu.com/f?kz=97589645
对单元格设置保护后,双击会弹出对话框提示不可对只读单元格进行写操作,怎么样才能不弹出对话框呢?
解答:
在工作表的双击事件中加入:  
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If ActiveSheet.ProtectContents And Target.Locked Then
Cancel = True
End If
End Sub
知识点:很多事件的后面都有一个Cancel(取消)属性,将这个属性设定为True就可以不运行这个事件,比如BeforeClose(关闭),BeforeSave(保存),BeforePrint(打印)等。然后跟据ProtectContents判断工作表是否保护,与用Locked判断双击的单元格是否保护。
如何编程根据第二列信息,随机重新将各行排列,使第二列相同信息不挨着。
http://post.baidu.com/f?kz=95957862
我单位经常组织职工考试,进行排考场,要求一个单位的职工不能前后桌,
故而请教上述问题。
解答:
Sub SJICFPS()
Dim MaxRow, BzCol, i, ii
MaxRow = 16 '最大行数
BzCol = 2 '不能重复数据所在列数
'先随机排序
For i = MaxRow To 2 Step -1
Randomize
ii = Int(Rnd * i + 1)
Rows(ii).Cut
Rows(i + 1).Select
Selection.Insert Shift:=xlDown
Next
'再检查是否有重复,如果有从下而下找一个合适的位置插入
For i = 2 To MaxRow - 1
If WorksheetFunction.CountIf(Range(Cells(i - 1, BzCol), Cells(i + 1, BzCol)), Cells(i, BzCol)) > 1 Then
For ii = 2 To MaxRow
If WorksheetFunction.CountIf(Range(Cells(ii - 1, BzCol), Cells(ii, BzCol)), Cells(i, BzCol)) = 0 Then
Rows(i).Cut
Rows(ii).Select
Selection.Insert Shift:=xlDown
If ii > i Then i = i - 1
Exit For
End If
Next
If ii > MaxRow Then
MsgBox "数据中" & Cells(i, BzCol) & "人数据过半", , "错误"
Exit Sub
End If
End If
Next
End Sub
知识点:利用Excel自带的CountIf来判断是否重复。VBA很好用,但与对Excel基础知识的了解程度是很有关系的。在VBA编程的同时,要好好的利用Excel原有的功能。
如何在已经设定好公式的很多单元格里加上同一段小公式?
http://post.baidu.com/f?kz=98891956
我已经在很多单元格内设置了所需的不同公式,我想在这些单元格内的公式前再加上一小段共同的公式,请问该如何做?谢谢。
例如:原来的公式
        A         B          C
1     =1+1      =2+2       =3+3
添加后的公式
         A          B          C
1     =3*1+1     =3*2+2     =3*3+3
解答:
首先选择要添加的单元格,再运行此宏:
Sub ZJ()
Dim XR As Range
For Each XR In Selection
XR.FormulaR1C1 = Replace(XR.FormulaR1C1Local, "=", "=3*", , 1)
Next
End Sub
知识点:用好Selection(选择区域的单元格)可以增加程序的可扩展性与灵活性,除此这外还用到Replace这个替换函数,要注意的一点是最后的1,即替换一次,因为公式中有可能有多个=号哦。
如何用VBA编程任意交换两条记录?
http://post.baidu.com/f?kz=96454366
注意事项方法:选择一个X*Y的区域,再按住Ctrl键,选择另一个X*Y的区域,再运行此宏。
Sub QYDH()
Dim XR As Range, YR As Range
Dim SZ1, SZ2, Down
If Selection.Areas.Count = 2 Then
Set XR = Selection.Areas(1)
Set YR = Selection.Areas(2)
If Not Intersect(XR, YR) Is Nothing Then
Down = MsgBox(" 选择区域有重叠!" & vbCrLf & _
"对换后数据将有部份被覆盖!" & vbCrLf & _
" 是否继续?", vbYesNo)
If Down = vbNo Then Exit Sub
End If
If XR.Rows.Count = YR.Rows.Count And XR.Columns.Count = YR.Columns.Count Then
SZ1 = XR.Formula
SZ2 = YR.Formula
XR = SZ2
YR = SZ1
Else
MsgBox "选择的两个区域不相同!"
End If
Else
MsgBox "请选择二个相同的区域!"
End If
End Sub
知识点:Areas属性是代表多重选定区域中的所有区域,而利用Intersect可以判断两个区域是否有重叠。
请问怎样才能在上千个工作表中同时取消保护工作表的密码呢?
http://post.baidu.com/f?kz=96158764
EXCEL工作簿中有上千个工作表,每张工作表都加密,请问怎样才能在上千个工作表中同时取消保护工作表的密码呢?
解答:
如果密码都相同,可以用
Sub SheetUnprotect()
Dim XS As Worksheet
Dim PS As String
PS = "111" '你的密码"
For Each XS In ActiveWorkbook.Worksheets
XS.Unprotect PS
Next
End Sub
知识点:利用循环在ActiveWorkbook.Worksheets(当前工作簿的工作表集合)循环,Unprotect就是取消工作表或工作簿的保护,如果设定了密码,后面还要加上密码。而protect就是设定保护。
怎样用Excel宏读文本文件
http://post.baidu.com/f?kz=93448449
解答:
Sub OpenTextFile()
Dim FN As String
FN = Application.GetOpenFilename("文本文件 *.txt,*.txt", , "请选择一个Excel文件")
If CStr(FN) = "False" Then
MsgBox "没有选择文件"
ElseIf Len(Dir(FN)) = 0 Then
MsgBox "文件不存在!"
Else
Workbooks.Open FN
End If
End Sub
知识点:GetOpenFilename会显示标准的“打开”对话框,获取用户文件名,但没有真正打开任何文件。而再用Open方法来打开它,这里的文件可以是Excel支持的任何格式的文件。这个程序还用到Dir这个函数,如果文件存在,dir会返回其路径,而由此判断文件是否存在。
激活Sheet1时自动隐藏工作簿中的其它工作表。
http://post.baidu.com/f?kz=93108210
在Worksheet的Activate事件中加入如下代码。  
Private Sub Worksheet_Activate()
Dim XS As Worksheet
For Each XS In ThisWorkbook.Worksheets
If XS.Name <> ActiveSheet.Name Then
XS.Visible = xlSheetHidden
End If
Next
End Sub
知识点:还是在ActiveWorkbook.Worksheets(当前工作簿的工作表集合)循环,ActiveSheet是当前的工作表,当不是当前工作表时,将其Visible属性设定为xlSheetHidden就可以隐藏工作表了。
如何判断工作表表存不存在?
http://post.baidu.com/f?kz=92833551
Sub PdSheet()  
On Error Resume Next  
Dim XS As Worksheet, SN As String  
SN = "sheet12"  
Set XS = Worksheets(SN)  
If XS Is Nothing Then  
MsgBox SN & "不存在!"  
Else  
MsgBox SN & "存在!"  
End If  
End Sub
知识点:用Set将变量设定为这个工作表,如果存在这个变量就不会为Nothing,而不存在时会产生一个错误,此时为了让程序继续运行,就要用到On Error Resume Next
如何编程设定表格线?
解答:
Sub Text()
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
MsgBox "设定好了!"
Selection.Borders.LineStyle = xlNone
MsgBox "又把它删除了!"
End Sub
知识点:Borders属性代表单元格的四个边框,其下面的属性还可以设定边框的LineStyle(线型)Weight(线宽)ColorIndex(线色)等,而取消则设定为xlNone。
如何选定区域自动排序?
http://post.baidu.com/f?kz=92148880
如何一用鼠标选定某一区域后使此区域的数据自动排序?我说的是具有灵活性,区域不能老制定一个区域。
解答:
Sub SelectionSort()
'如果选择只有一个区域
If Selection.Areas.Count = 1 Then
'将选择区域按当前单元格所在列排序
Selection.Sort Key1:=Cells(Selection.Item(1).Row, ActiveCell.Column)
Else
'将选择区域的第一个区域按第一列排序
Selection.Areas(1).Sort Key1:=Selection.Item(1)
End If
End Sub
知识点:
Sort方法可以对指定的单元格进行排序。用Selection.Item(1).Row返回选择区域中第一个单元格的行数,用ActiveCell.Column返回当前单元格的列数,并与此为条件进行排序。
把sheet1的内容全部复制到sheet2,语句怎么写?
http://post.baidu.com/f?kz=91993595
解答:
Sub Text()
Worksheets("sheet1").Select
Cells.Copy
Worksheets("sheet2").Select
ActiveSheet.Paste
End Sub
知识点:cells代表活动工作表中的所有单元格。而用Copy方法来完成复制,Paste方法来完成粘贴。
按颜色与顺序分别列出数据。
http://post.baidu.com/f?kz=91956078
在A1:A10中有的数字字体是红色有的是蓝色有的是黑色,三种颜色,我想在B列从B1开始显示按顺序显示其中所有红色的数字,C列从C1按顺序显示蓝色的数字,D列从D1开始按顺序显示黑色的数字。
解答:
Sub text()
Dim TRan As Range
For Each TRan In [A1:A10]
Select Case TRan.Font.ColorIndex
Case 3
Cells(WorksheetFunction.CountA(Columns(2)) + 1, 2) = TRan
Case 5
Cells(WorksheetFunction.CountA(Columns(3)) + 1, 3) = TRan
Case Else
Cells(WorksheetFunction.CountA(Columns(4)) + 1, 4) = TRan
End Select
Next
End Sub
知识点:Font对象包含对象的字体属性(字体名称、字体大小、字体颜色等),用Select Case 语句就可以来完成多条件选择判断。
如何用vb实现excel单元格的查询?
http://post.baidu.com/f?kz=91131696
Sub Text()
Dim TMP As String
TMP = "aa"
With Cells
Set c = .Find(TMP, LookIn:=xlvalues)
If Not c Is Nothing Then
MsgBox "第" & c.Row & "行/第" & c.Column & "列"
End If
End With
End Sub
知识点:Find方法:在工作表中查找特定信息。
如何将包含多个工作表的工作组中双面打印?
http://post.baidu.com/f?kz=104650320
如果不用宏,可以试试先选择第1,3,5,……然后打印,将纸手动翻页,再选择2,4,6……再打印。
如果工作表N多,可以运行此宏
Sub QOPS()
For i = 3 To Worksheets.Count Step 2
Worksheets(i).Move Worksheets((i + 1) / 2)
Next
End Sub
这个宏的结果是将原来奇偶页移到一起,再选择工作表,打印。
还原再运行:
Sub QOHY()
For i = Int((Worksheets.Count + 1) / 2) + 1 To Worksheets.Count
Worksheets(i).Move Worksheets((i - Int((Worksheets.Count + 1) / 2)) * 2)
Next
End Sub
知识点:其中只用到了工作表的Move方法,而算法其实很简单了。
如何在一个5×5的表格中随机且不重复地输入1-25这二十五个数?
http://post.baidu.com/f?kz=103448966
试试这段宏:
Sub SJS()
Dim TMP(24)
For i = 0 To 24
TMP(i) = i + 1
Next
For i = 25 To 1 Step -1
Randomize
j = Int(i * Rnd) + 1
ActiveCell.Offset((25 - i) \ 5, (25 - i) Mod 5) = TMP(j - 1)
t = TMP(i - 1)
TMP(i - 1) = TMP(j - 1)
TMP(j - 1) = t
Next
End Sub
知识点:这是一个随机输出不重复序列的实例,是利用一个数组与RND来完成的。
获得当前单元格所在的页面:
http://post.baidu.com/f?kz=110250335
解答:
Sub PrintActivePage()
Dim VPC As Integer
Dim HPC As Integer
Dim VPB As VPageBreak
Dim HPB As HPageBreak
Dim NumPage As Integer
  
If ExecuteExcel4Macro("Get.Document(50)") = 0 Then
MsgBox "Excel 找不到列印的内容"
Exit Sub
End If
  
If ExecuteExcel4Macro("Get.Document(50)") = 1 Then
ActiveSheet.PrintOut From:=1, To:=1, Copies:=1
Exit Sub
End If
  
'先判断编页码的顺序也就是版面设定的循栏列印或循列列印
If ActiveSheet.PageSetup.Order = xlDownThenOver Then
HPC = ActiveSheet.HPageBreaks.Count + 1
VPC = 1
Else
VPC = ActiveSheet.VPageBreaks.Count + 1
HPC = 1
End If
  
NumPage = 1
  
Application.ScreenUpdating = True
ActiveWindow.View = xlPageBreakPreview
For Each VPB In ActiveSheet.VPageBreaks
If VPB.Location.Column > ActiveCell.Column Then Exit For
NumPage = NumPage + HPC
Next VPB
  
For Each HPB In ActiveSheet.HPageBreaks
If HPB.Location.Row > ActiveCell.Row Then Exit For
NumPage = NumPage + VPC
Next HPB
  
'取得页数後再判断目前储存格是否在列印范围中
If Intersect(ActiveSheet.UsedRange, ActiveCell) Is Nothing Then
MsgBox "目前储存格不在列印范围中"
Else
MsgBox "目前储存格在第" & NumPage & "页"
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
知识点:利用宏表函数Get.Document来获得当前打印的总页数,再利用PageSetup.Order(打印的次序)、HPageBreaks(水平分页符的集合)、VPageBreaks(垂直分页符的集合)等属性,来算出ActiveCell(当前单元格)的页码。

为了您的安全,请只打开来源可靠的网址
打开网站    取消
来自: http://hi.baidu.com/tszsc/blog/item/77589b0771c29fc57b8947d0.html
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|龙网论坛 ( 辽ICP备06014320号 )

GMT+8, 2022-9-26 17:34

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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