VBA菜鸟求助。
根据指定字段，进行数据整理。
详情如图，盼高手解答。
级数略低，尚不能上传附件。

试试这种方式，可以保留格式
Sub bbb()
Dim Cnum1%, Cnum2%, Rnum%, FC As Range
Cnum1 = Sheet1.Range("a2").End(xlToRight).Column
Cnum2 = Sheet1.Range("a1").End(xlToRight).Column
Rnum = Sheet1.Range("a65536").End(xlUp).Row - 1
Sheet1.Range("a1").Resize(1, Cnum2).Copy Sheet1.Cells(1, Cnum1 + 1)
For i = Cnum1 + 1 To Cnum1 + Cnum2
Set FC = Sheet1.Rows(2).Find(Sheet1.Cells(1, i), , , xlWhole)
If Not FC Is Nothing Then
Sheet1.Cells(2, FC.Column).Resize(Rnum, 1).Copy Sheet1.Cells(1, i)
End If
Next i
Sheet1.Range(Columns(1), Columns(Cnum1)).Delete
End Sub

@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

For i = 1 To Sheet1.Range("a1").End(xlToRight).Column '循环嵌套一，遍历修改后的所有类别，从a1单元格一直到第一行最后一项所在的单元格
For j = 1 To UBound(Arr1, 2) '循环嵌套二，假设arr1(1 to x,1 to y)则遍历第二维度，循环1 to y既为遍历原所有类别
If Sheet1.Cells(1, i) = Arr1(1, j) Then '如果目标类别和原类别相同则符合判断
Sheet1.Cells(1, i).Resize(UBound(Arr1), 1) = Application.Index(Arr1, , j) '讲数组中符合的列单独取出填入表中对应列，Resize是为了填入区域要和数组长度吻合，Application.Index负责单独提取出二维数组里的某一行或列，这里是提出j列
Exit For '既然已经找到符合的列，那么就可以退出当前循环（j的循环）节省时间提高效率
End If
Next j
Next i

请求大神@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

看来得买本清华大学出版社的《Excel 2013 VBA入门与应用》,用案例一个一个来学习VBA才是王道。

自己来盖楼
写了一小段，可以用来统计打印区域内的文字数。
其中有一个小问题是，百分比的字符数=实际数值的字符数，100%就算1个字符了。。
Sub strCount()
Dim rng As Range, strCount
For Each rng In Range("Print_Area")
If Len(rng) > 0 Then
strCount = Len(rng) + strCount
End If
Next rng
MsgBox "文字数：" & strCount
' Range("k4") = "文字数：" & strCount
End Sub

呼叫@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 text()
Dim i, x
Open "C:\Documents and Settings\Administrator\桌面\new.xml" For Output As #1
x = "<?xml version=""1.0"" encoding=""utf-8"" standalone=""yes""?>"
Print #1, x
x = "<asss>"
Print #1, x
x = " <ass "
For i = 1 To 3
x = x & "a1=""" & Cells(1, i) & """ "
Next i
x = x & "/>"
Print #1, x
x = "</asss>"
Print #1, x
Close #1
End Sub
当cells(1,1) ~cells(1,3)为繁体的时候，输出在桌面的new.xml是乱码的

秋高气爽，盖楼以表庆祝。
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

找到办法解决度娘吃缩进，使用时可以用4个空格置换空字。
下面的代码具体的功能有2个，一是根据指定字段整理内容；二是对分别筛选指定列的内容，也就是拆分汇总表为各个子工作簿。
Sub sheets2wks()
空Application.ScreenUpdating = False
空Application.DisplayAlerts = False
*------------------------------------------------------------------------------
*-----------------------------------整理内容-----------------------------------
*------------------------------------------------------------------------------
空Dim ColnumOld As Integer, ColnumNew As Integer
空Dim DataRow As Integer, ColCnt As Integer
空Dim FindCol As Range
空Dim HeaderArr()
空Dim ParentFile As Workbook
空*确认要保留的字段
空HeaderArr = Array("No.", "姓名", "地区", "电话")
空*定义打开的工作簿为「ParentFile」
空Set ParentFile = ActiveWorkbook
空*在「ParentFile」的第一行插入保留的字段内容
空With ParentFile.Sheets(1)
空空.Rows(1).Insert shift:=xlDown
空空.Range(Cells(1), Cells(1, UBound(HeaderArr) + 1)) = HeaderArr
空End With
空*定义原字段为「ColnumOld」
空*定义新字段为「ColnumNew」
空*根据A列的内容定义行数为「DataRow」
空ColnumOld = Range("A2").End(xlToRight).Column
空ColnumNew = Range("A1").End(xlToRight).Column
空DataRow = Range("A65536").End(xlUp).Row - 1
空*将新字段「ColnumNew」粘贴到原字段「ColnumOld」的右侧
空ParentFile.Sheets(1).Range("A1").Resize(1, ColnumNew).Copy Cells(1, ColnumOld + 1)
空*匹配内容粘贴至「ColnumNew」处
空For ColCnt = ColnumOld + 1 To ColnumOld + ColnumNew
空空Set FindCol = Rows(2).Find(Cells(1, ColCnt), , , xlWhole)
空空If Not FindCol Is Nothing Then
空空空Cells(2, FindCol.Column).Resize(DataRow, 1).Copy Cells(1, ColCnt)
空空End If
空Next ColCnt
空Range(Columns(1), Columns(ColnumOld)).Delete
*------------------------------------------------------------------------------
*----------------------------------生成子文件----------------------------------
*------------------------------------------------------------------------------
空Dim iDic As Object
空Dim KeyRng As Range
空Dim KeyRows As Integer, KeyNum As Integer
空Dim KeyArr
空Dim SubFile As Workbook
空Dim FileName As String, SavePath As String
空*C列内容装入字典「iDic」
空Set iDic = CreateObject("Scripting.Dictionary")
空KeyRows = Range("C2").End(xlDown).Row
空For Each KeyRng In Range("C2:C" & KeyRows)
空空If Not iDic.exists(KeyRng.Value) Then iDic.Add (KeyRng.Value), ""
空Next
空*将字典「iDic」的主键代入数列「KeyArr」
空*定义扩展名以外的文件名「FileName」
空*定义子文件保存路径为「SavePath」
空KeyArr = iDic.keys
空FileName = Mid(ParentFile.Name, 1, (InStr(ParentFile.Name, ".") - 1))
空SavePath = ParentFile.Path & "\" & ParentFile.Name & "_Cuted"
空*保存路径「SavePath」不存在时，新建「SavePath」
空*根据主键内容分别筛选，将结果粘贴至新建工作簿
空If Dir(SavePath, vbDirectory) = "" Then MkDir SavePath
空For KeyNum = 0 To iDic.Count - 1
空空Set SubFile = Workbooks.Add(xlWBATWorksheet)
空空With ParentFile.Sheets(1)
空空空If .FilterMode = True Then .ShowAllData
空空空.Range("A1").AutoFilter field:=3, Criteria1:=KeyArr(KeyNum)
空空空.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy SubFile.Sheets(1).Range("A1")
空空End With
空空*子文件的工作表名为主键内容
空空SubFile.Sheets(1).Name = KeyArr(KeyNum)
空空*子文件的文件名为「FileName_主键」
空空SubFile.Close savechanges:=True, FileName:=SavePath & "\" & FileName & "_" & KeyArr(KeyNum)
空Next
空ParentFile.Sheets(1).Activate
空ParentFile.Sheets(1).[A1].AutoFilter
*------------------------------------------------------------------------------
空Application.DisplayAlerts = True
空Application.ScreenUpdating = True
End Sub