EXCEL VBA代码集

龙哥

求单元格公式变为字符串的方法
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