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

试试这种方式，可以保留格式
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

自己来盖楼
写了一小段，可以用来统计打印区域内的文字数。
其中有一个小问题是，百分比的字符数=实际数值的字符数，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