VBA代码个人云笔记

一楼
标题：选中工作表中真正有数据的区域
问题：当表中有格式，如颜色填充时，用usedrange会把没有数据的部分也选中
思路：利用SpecialCells选中有数据的Areas，遍历每个area找出四个角的单元格
代码：
Sub MyUserRange()
Dim rA As Range, rB As Range, rC As Range, rD As Range
Dim toprow As Long, bottommost As Long, leftmost As Integer, rightmost As Integer
If TypeName(Selection) <> "Range" Then Exit Sub
On Error Resume Next
Set rA = Cells.SpecialCells(xlConstants)
Set rB = Cells.SpecialCells(xlFormulas)
rA.Select
rB.Select
Union(rA, rB).Select
On Error GoTo 0
Set rC = Selection
toprow = rC.Areas(1).Rows(1).Row
bottommost = rC.Areas(1).Rows(rC.Areas(1).Rows.Count).Row
leftmost = rC.Areas(1).Columns(1).Column
rightmost = rC.Areas(1).Columns(rC.Areas(1).Columns.Count).Column
For Each rD In rC.Areas
If rD.Rows(1).Row < toprow Then toprow = rD.Rows(1).Row
If rD.Rows(rD.Rows.Count).Row > bottommost Then bottommost = rD.Rows(rD.Rows.Count).Row
If rD.Columns(1).Column < leftmost Then leftmost = rD.Columns(1).Column
If rD.Columns(rD.Columns.Count).Column > rightmost Then rightmost = rD.Columns(rD.Columns.Count).Column
Next rD
Range(Cells(toprow, leftmost), Cells(bottommost, rightmost)).Select
End Sub
用途例子：删除多余的空行
Sub DeleteEmptyRows()
Dim rS As Range, rA As Range
Dim lFirstRow As Long
Call UsedSelect
Set rS = Selection
lFirstRow = rS.Rows(rS.Rows.Count).Row + 1
Set rA = Range(Rows(lFirstRow), Rows(Rows.Count))
rA.Select
If MsgBox("Are you sure for DELETE selection rows?" & vbCr & rA.Address, vbYesNo, "Delete empty rows!") = vbYes Then
rA.delete Shift:=xlTop
End If
End Sub

二楼
标题：忘记工作表蜜**马怎么办
问题：如果是工作簿，这个议题好像是不能吧里讨论的，但工作表里是Microsoft故意留下防 止大家忘记的。
思路：这个是多年前百度里搜出来的
代码：
Sub Unscramble()
Dim S1 As Integer
Dim S2 As Integer
Dim S3 As Integer
Dim S4 As Integer
Dim S5 As Integer
Dim S6 As Integer
Dim S7 As Integer
Dim S8 As Integer
Dim S9 As Integer
Dim S10 As Integer
Dim S11 As Integer
Dim Sn As Integer
On Error Resume Next
For S1 = 65 To 66: For S2 = 65 To 66: For S3 = 65 To 66: For S4 = 65 To 66: For S5 = 65 To 66: For S6 = 65 To 66
For S7 = 65 To 66: For S8 = 65 To 66: For S9 = 65 To 66: For S10 = 65 To 66: For S11 = 65 To 66: For Sn = 32 To 128
ActiveSheet.Unprotect (Chr(S1) & Chr(S2) & Chr(S3) & Chr(S4) & Chr(S5) & Chr(S6) _
& Chr(S7) & Chr(S8) & Chr(S9) & Chr(S10) & Chr(S11) & Chr(Sn))
If ActiveSheet.ProtectContents = False Then
MsgBox Chr(S1) & Chr(S2) & Chr(S3) & Chr(S4) & Chr(S5) & Chr(S6) _
& Chr(S7) & Chr(S8) & Chr(S9) & Chr(S10) & Chr(S11) & Chr(Sn)
Exit Sub
End If
Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
On Error GoTo 0
End Sub

三、
标题：选中重复的单元格（第一个除外），并改变颜色
问题：Excel自带的条件样式，并没有真正改变重复格的颜色
思路：遍历选中单元格区域，把重复的第一个标purple,之后的标红色。选中全部重复的。
代码：
Sub UsedSelect2()
Dim rA As Range, rb As Range, rC As Range, rD As Range
Dim toprow As Long, bottommost As Long, leftmost As Integer, rightmost As Integer
If TypeName(Selection) <> "Range" Then Exit Sub
On Error Resume Next
Set rA = Selection.Cells.SpecialCells(xlConstants)
Set rb = Selection.Cells.SpecialCells(xlFormulas)
rA.Select
rb.Select
Union(rA, rb).Select
On Error GoTo 0
Set rC = Selection
toprow = rC.Areas(1).Rows(1).Row
bottommost = rC.Areas(1).Rows(rC.Areas(1).Rows.Count).Row
leftmost = rC.Areas(1).Columns(1).Column
rightmost = rC.Areas(1).Columns(rC.Areas(1).Columns.Count).Column
For Each rD In rC.Areas
If rD.Rows(1).Row < toprow Then toprow = rD.Rows(1).Row
If rD.Rows(rD.Rows.Count).Row > bottommost Then bottommost = rD.Rows(rD.Rows.Count).Row
If rD.Columns(1).Column < leftmost Then leftmost = rD.Columns(1).Column
If rD.Columns(rD.Columns.Count).Column > rightmost Then rightmost = rD.Columns(rD.Columns.Count).Column
Next rD
Range(Cells(toprow, leftmost), Cells(bottommost, rightmost)).Select
End Sub
Public Sub RepeatSelect()
Dim a, b, c, d, e
Dim rA As Range, rb As Range, rC As Range, rOriginal As Range, rNotEmpty As Range, rRed As Range
Dim stFirstAddress As String 'OriginalAddress
Dim iA As Double, iB As Double, iC As Double
Dim bContinue As Integer
If TypeName(Selection) <> "Range" Then Exit Sub
Call UsedSelect2
Set rNotEmpty = Selection
If rNotEmpty.Cells.Count > 65536 Then MsgBox "Overstep 65536 cells": Exit Sub
iB = 0
iC = 0
For Each rA In rNotEmpty
If rA.Interior.ColorIndex <> xlNone Then
bContinue = MsgBox("That will clear all the interior color in the cells which you selection," & _
vbCr & "Continue?", vbYesNo)
Exit For
End If
Next rA
If bContinue = vbNo Then Exit Sub
rNotEmpty.Interior.ColorIndex = xlNone
For Each rA In rNotEmpty
If rA.Interior.ColorIndex <> 3 And rA <> Empty Then
iA = 0
stFirstAddress = rA.Address
Set rC = rNotEmpty.Find(rA, After:=rA, lookat:=xlWhole, MatchCase:=True)
If Not rC Is Nothing Then
If rC.Address <> stFirstAddress Then
rA.Interior.ColorIndex = 7
rC.Interior.ColorIndex = 3
If rRed Is Nothing Then
Set rRed = rC
Else
Set rRed = Union(rRed, rC)
End If
iA = iA + 1
End If
Do
Set rC = rNotEmpty.FindNext(rC)
If Not rC Is Nothing And rC.Address <> stFirstAddress Then
rC.Interior.ColorIndex = 3
Set rRed = Union(rRed, rC)
iA = iA + 1
End If
Loop While Not rC Is Nothing And rC.Address <> stFirstAddress
End If
iC = iC + iA
If iA > 0 Then iB = iB + 1
End If
Next rA
MsgBox "There are " & iB & " Value repeat." & vbCr & "Total " & iC & " cells."
rRed.Select
End Sub
用途：选中重复的后可方便后续操作，如删除。

四、
标题：判断工作簿是否已经打开
思路：遍历全部打开的工作簿看有没有目标工作簿的名字
代码：
Function wbIsOpen(wbNameWithExtension As String)
Dim wbS As Workbook, wbA As Workbook, bResult As Boolean
For Each wbA In Workbooks
If wbA.Name = wbNameWithExtension Then
bResult = True
Exit For
End If
Next wbA
wbIsOpen = bResult
End Function

五、
标题：列出选中文件夹中的文件并hyperlink
Remark: 以当前单元格开始往下列出
代码：
Sub GetFilesList()
Dim strA As String, strFileName As String
Dim iA As Integer
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
strA = .SelectedItems(1)
strFileName = Dir(strA & "\*.*")
Do While strFileName <> ""
'ActiveCell.Offset(iA, 0) = strFileName' Only file name with out path or hyperlink.
ActiveCell.Offset(iA, 0).Hyperlinks.Add anchor:=ActiveCell.Offset(iA, 0), Address:=strA & "\" & strFileName
strFileName = Dir
iA = iA + 1: If iA = 1000 Then End
Loop
End If
End With
End Sub

六、
标题：Application.Inputbox
Remark：和Inputbox函数不同，可设type参数为8，返回单元格（直接在表中选取就行，有点像Excel函数）
思路：先选中一个区域，用这个宏减去不想选中的部分
代码：
Sub Selection_subtract()
Dim a, b, one, n, i, j, c, two
Application.ScreenUpdating = True
On Error Resume Next
Set a = Selection
If Selection.Cells.Count > 65536 Then Exit Sub
Set b = Application.InputBox(prompt:="choose", Type:=8, Left:=1, Top:=-80)
If b Is Nothing Then Exit Sub
If b.Cells.Count > 599 Then Exit Sub
For Each one In a
n = 0
For Each two In b
If one.Address = two.Address Then n = 1
Next two
If n = 0 Then j = j + 1
If j = 1 And n = 0 Then Set c = one
If j > 1 And n = 0 Then Set c = Application.Union(c, one)
Next one
If j = 0 Then [A1].Select: Exit Sub
c.Select
End Sub
这是我多年前初学时写的，很不规范！

七、
标题：暂停----以毫秒计算
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'上面这句一定要放在顶部
Sub Sleep_()
Debug.Print Timer
Sleep 500
Debug.Print Timer
End Sub

八、
标题：插入空行
Remark：今天有Excel吧友问这个问题，每隔几行插入一行空行
代码：
Sub InsertRow(iInterval As Integer, Optional lFirstRow As Long)
Dim rArea As Range
Dim lA As Long
Set rArea = ActiveSheet.UsedRange
If lFirstRow = 0 Then lFirstRow = rArea.Rows(1).Row
lFirstRow = lFirstRow + iInterval - 1
For lA = lFirstRow To rArea.Rows(rArea.Rows.Count).Row Step iInterval + 1
Rows(lA + rArea.Rows(1).Row - 1).Insert
Next lA
End Sub
Sub TryInsertrow()
Call InsertRow(3, 6)
End Sub
'注意：插入空行会导致usedrange的行数变多，可以用一楼的”用途例子：删除多余的空行”解决。

十、运行其他应用程序
把下面列句中“C:\......”改为要打开的文件名（含路径）。
Sub WscriptRun()
CreateObject("Wscript.shell").Run "C:\Users\A8-5600K\Desktop\YourEmailName.msg", 3
End Sub