ExcelVBA求助，根据指定内容整理数据

@ninart 大神的第一种方法，重新发上来。
Sub headdata()
Dim Arr1, i, j
Application.ScreenUpdating = False
Arr1 = ActiveSheet.Range(ActiveSheet.Range("a2"), ActiveSheet.Range("a2").End(xlToRight).End(xlDown))
ActiveSheet.Range(ActiveSheet.Range("a2"), ActiveSheet.Range("a2").End(xlToRight).End(xlDown)).ClearContents
ActiveSheet.UsedRange.NumberFormatLocal = "@"
For i = 1 To ActiveSheet.Range("a1").End(xlToRight).Column
For j = 1 To UBound(Arr1, 2)
If ActiveSheet.Cells(1, i) = Arr1(1, j) Then
ActiveSheet.Cells(1, i).Resize(UBound(Arr1), 1) = Application.Index(Arr1, , j)
Exit For
End If
Next j
Next i
Range("C2").Select
Application.ScreenUpdating = True
End Sub

请求大神@ninart 帮助！
通过录制宏得到一段设置单元格格式的代码，删除了其中一些无效代码，但还是长度还是很长。
有没有办法优化一下，感觉Borders那部分应该有个All之类的一起设定吧。
Columns("T:X").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 38
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 38
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 38
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 38
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 38
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 38
End With
With Selection.Interior
.PatternColorIndex = xlAutomatic
.color = 16764057
End With

呼叫@ninart 大神思密达
关于批注的显示，想向大神求教。
现在在B列有一组数据，B1单元格以下有一些含有批注。
对B列筛选之后，可见单元格中有3个含有批注，如何一次性全部显示批注？
录制的宏每次只能显示一个批注

请教@ninart 大神，最近用窗体做了一个输入小工具，怎样能做成加载项，让其他人也可以加载后使用？
另外，没有vba的WPS能不能使用？

来盖楼，今天贴的是给窗体加上最大化最小化
Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_MINIMIZEBOX As Long = &H20000 *(最小化)
Private Const WS_MAXIMIZEBOX As Long = &H10000 *(最大化)
---------------------------------------------------------
Private Sub UserForm_Initialize()
Dim hWndForm As Long
Dim IStyle As Long
hWndForm = FindWindow("ThunderDFrame", Me.Caption)
IStyle = GetWindowLong(hWndForm, GWL_STYLE)
IStyle = IStyle Or WS_THICKFRAME
IStyle = IStyle Or WS_MINIMIZEBOX *最小化
IStyle = IStyle Or WS_MAXIMIZEBOX *最大化
SetWindowLong hWndForm, GWL_STYLE, IStyle
End Sub

代码中最大化最小化前面的*应该是'

指定路径下txt文件转换为html文件
本例中指定路径为F:\Data\
Sub txt2html()
Const OLD_EXTENSION As String = ".txt"
Const NEW_EXTENSION As String = ".html"
Const SAVE_DIR As String = "F:\Data\"
Dim OldFName As String
Dim NewFName As String
OldFName = Dir(SAVE_DIR & "*" & OLD_EXTENSION)
Do While Len(OldFName) <> 0
OldFName = SAVE_DIR & OldFName
NewFName = Left(OldFName, Len(OldFName) - Len(OLD_EXTENSION)) & NEW_EXTENSION
FileCopy OldFName, NewFName
Kill OldFName
OldFName = Dir()
Loop
End Sub

Sub 返回单元格颜色()
Dim myR As Long, myG As Long, myB As Long
Dim myColor As Long
myColor = ActiveCell.Interior.Color
myR = myColor Mod 256
myG = Int(myColor / 256) Mod 256
myB = Int(myColor / 256 / 256)
MsgBox "R: " & myR & vbLf & _
"G: " & myG & vbLf & _
"B: " & myB
End Sub

秋高气爽，盖楼以表庆祝。
Sub 汇总活动工作簿的各个工作表()
Dim sWS As Worksheet
Dim dWS As Worksheet
On Error Resume Next
Set dWS = Worksheets("AllData")
If Err.Number <> 0 Then
Set dWS = Worksheets.Add(Worksheets(1))
dWS.Name = "AllData"
End If
*删除第2行以下的内容
dWS.UsedRange.Offset(1, 0).Clear
*复制第二个工作表首行内容
Worksheets(2).Range("1:1").Copy Worksheets("AllData").Range("1:1")
For Each sWS In Worksheets
If sWS.Name <> dWS.Name Then
With sWS.UsedRange
If .Rows.Count > 1 Then
.Offset(1, 0).Resize(.Rows.Count - 1).Copy _
Destination:=dWS.Cells(Rows.Count, 1). _
End(xlUp).Offset(1, 0)
End If
End With
End If
Next sWS
Set dWS = Nothing
End Sub

下面的代码可以配合17L的生成汇总表使用
Sub 生成不重复名单且条件求和()
Dim FCol As Range, LCol As Range, NewFCol As Range
Dim myDic As Object, myKey, myItem, myVal
Dim i As Long
Set FCol = ActiveSheet.UsedRange.Cells(1)
Set LCol = FCol.End(xlToRight)
Set NewFCol = LCol.Offset(0, 2)
Set myDic = CreateObject("Scripting.Dictionary")
Range(FCol, LCol).Copy NewFCol
* ---将数据放入数组
myVal = Range(FCol.Offset(1, 0), Cells(Rows.Count, FCol.Column).End(xlUp)).Resize(, 2).Value
* ---将数据放入字典myDic
For i = 1 To UBound(myVal, 1)
If Not myVal(i, 1) = Empty Then
If Not myDic.exists(myVal(i, 1)) Then
*---为新条目时添加key和item
myDic.Add myVal(i, 1), myVal(i, 2)
Else
*---条目已存在时item值相加
myDic(myVal(i, 1)) = myDic(myVal(i, 1)) + myVal(i, 2)
End If
End If
Next
* ---输出Key,Item
myKey = myDic.keys
myItem = myDic.items
For i = 0 To UBound(myKey)
Cells(i + FCol.Row + 1, NewFCol.Column).Value = myKey(i)
Cells(i + FCol.Row + 1, NewFCol.Column + 1).Value = myItem(i)
Next
Set myDic = Nothing
End Sub

可以设置按钮，自动打开浏览器，分别百度选中单元格的内容
Sub mySearching()
Dim mySearchEngine As String
Dim rng As Range
mySearchEngine = "http://www.baidu.com/s?wd="
For Each rng In Selection
Shell "浏览器本地路径（引号中最后一位为半角空格） " & mySearchEngine & rng.Text , vbNormalFocus
Next rng
End Sub

根据表二的A1单元格从表一筛选数据复制到表二
Sub M1()
Dim datarng As Range
Set datarng = Worksheets(1).Range("A1").CurrentRegion
Worksheets(2).Range("B1", Range("B1").End(xlDown).End(xlToRight)).ClearContents
If Len(Worksheets(2).Range("A1")) = 0 Then
MsgBox "Please input the contents in A1 cells!"
Else
With datarng
.AutoFilter Field:=1, Criteria1:=Worksheets(2).Range("A1").Text
.SpecialCells(xlCellTypeVisible).Copy Worksheets(2).Range("B1")
End With
Worksheets(1).AutoFilter.Range.AutoFilter
End If
End Sub

将表一A列内容存入字典，并作为表二A1单元格的数据有效性列表
可以配合上面的FilterCopy一起使用
Sub FilterDicValid()
Dim Arr, lRows As Long
Dim myDic As Object
Dim i As Long
Application.ScreenUpdating = False
Worksheets(1).Activate
With Range("A2", Range("A2").End(xlDown))
lRows = .Rows.Count
Arr = .Value
End With
Set myDic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
myDic(Arr(i, 1)) = ""
Next
With Worksheets(2).Range("A1").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(myDic.keys, ",")
End With
Set myDic = Nothing
Worksheets(2).Activate
Application.ScreenUpdating = True
End Sub