Question

求excel 高手 用VBA/宏 实现将sheet1筛选后的内容粘贴至sheet2

例 把 相同班级 的筛选出来 分别粘到sheet2
（实际问题还要复杂太多，数据庞大无法一个一个筛选粘贴，请帮忙编一个程序，不胜感谢）
sheet1
A B C D
1 姓名 班级 学号 性别
2 王芳 1101 2 F
3 李林 1102 4 T
4 张涛 1103 11 T
5 李良 1102 7 F
6 钱红 1103 9 T
7 张三 1101 5 F

按班级筛选后 实现
A B C D
1 1101
2 姓名 班级 学号 性别
3 王芳 1101 2 F
4 张三 1101 5 F
5
6
7 1102
8 姓名 班级 学号 性别
9 李林 1102 4 T
10 李良 1102 7 F
11
12
13 1103
14 姓名 班级 学号 性别
15 张涛 1103 11 T
16 钱红 1103 9 T
数据筛选后以实现如下 如何复制该区域至新建的以A3（A3有数据有效性下拉选项）输入内容命名的sheet中，使得新 sheet中内容与筛选后内容完全一致，行高列宽也相同（当然只显示可见区域（下表已经实现隐藏空白行）
A B C D
1
2 生产商
3 商通(5TS)
4 Sanhua_Code Maker_Code Description Qty
220 KENHHAKLF42A - AWG14,BROWN,410mm 1
AWG14,BLUE,410mm;
AWG20,BLACK,420mm"
221 KENHHCAE023A - AWG20,230mm,green 1

Answer 1

程序如下，希望你喜欢：
Sub Run_Sort_Copy()
On Error GoTo ErrExit
Dim strSheetName_1 As String, strSheetName_2 As String
Dim iClass As Long, iMaxRow As Long, iRow As Long, iNewRow As Long
Application.ScreenUpdating = False
strSheetName_1 = "Sheet1" '此处可修改表1名称
strSheetName_2 = "Sheet2" '此处可修改表2名称
Sheets(strSheetName_1).Select
Range("A1").CurrentRegion.Select
iMaxRow = Selection.Rows.Count
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range( _
"C2"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
xlSortNormal, DataOption2:=xlSortNormal

iRow = 2
iClass = Range("B2").Value
iNewRow = 1
GoSub CopyMain
GoSub CopyRange

iRow = 3
Do Until iRow > iMaxRow
If Range("B" & iRow).Value = iClass Then
GoSub CopyRange
Else
iClass = Range("B" & iRow).Value
iNewRow = iNewRow + 2
GoSub CopyMain
GoSub CopyRange
End If
iRow = iRow + 1
Loop
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub

ErrExit:
MsgBox Err.Description, vbCritical, "错误"
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub

CopyMain:
Application.StatusBar = "正在处理 " & iRow & " / " & iMaxRow & " 行"
Sheets(strSheetName_2).Select
Range("A" & iNewRow) = iClass
iNewRow = iNewRow + 1
Sheets(strSheetName_1).Select
Rows("1:1").Select
Selection.Copy
Sheets(strSheetName_2).Select
Range("A" & iNewRow).Select
Selection.Insert Shift:=xlDown
iNewRow = iNewRow + 1
Sheets(strSheetName_1).Select
Return

CopyRange:
Application.StatusBar = "正在处理 " & iRow & " / " & iMaxRow & " 行"
Rows(iRow & ":" & iRow).Select
Selection.Copy
Sheets(strSheetName_2).Select
Range("A" & iNewRow).Select
Selection.Insert Shift:=xlDown
iNewRow = iNewRow + 1
Sheets(strSheetName_1).Select
Return
End Sub

追问

算了，我还是说一下实际问题吧。具体见补充问题
目前我有2张表 一张总表 一张筛选表。
筛选表中我已经利用数据有效性和 if 条件函数实现了筛选的目的 函数覆盖区域为 A5：D500，并用BVA加按钮实现了隐藏空白行和取消隐藏，将数据整合。
目前所需实现的是新建一个sheet 以原表中A3的内容命名，将筛选出来的数据拷贝至新建sheet中（只拷贝可见部分，新表与除了内容相同外希望行高列宽也不要发生变化）

追答

你试试这个程序：
Sub Run_Copy()
On Error GoTo ErrExit
Dim strSN_Old As String, strSN_New As String
Dim lgMaxRow As Long, lgNewRow As Long
Dim rgRows As Range
Application.ScreenUpdating = False
strSN_Old = ActiveSheet.Name
strSN_New = Range("A3").Value
lgNewRow = 1
lgMaxRow = Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
Sheets(strSN_Old).Copy After:=Sheets(strSN_Old)
ActiveSheet.Name = strSN_New
With Cells
.EntireRow.Hidden = False
.Clear
End With
Sheets(strSN_Old).Select
For Each rgRows In Rows("1:" & lgMaxRow)
Application.StatusBar = "正在处理 " & rgRows.Row & " / " & lgMaxRow& " 行"
If rgRows.EntireRow.Hidden = False Then
rgRows.Select
Selection.Copy
Sheets(strSN_New).Select
Range("A" & lgNewRow).Select
Selection.Insert Shift:=xlDown
lgNewRow = lgNewRow + 1
Sheets(strSN_Old).Select
End If
Next
Range("A3").Select
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub
ErrExit:
MsgBox Err.Description, vbCritical, "错误"
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

Answer 2

你的这个办法太笨.给你个方法:
全选整个数据区域,然后按班级排序.再在每个班级前面手工添加标题行.
如果你确实需要用VBA解决分班排序问题,可以放一个完整的数据样本的图上来.

Answer 3

直接粘贴QQ，在粘贴到sheet2 最笨的方法 呵呵