Excel实例下载
  VBA  应用教程
    数据库SQL知识
设为首页
按某列相同的值分到各工作表中
作者:bengdeng | 来源:Excel吧 | 时间:2006-09-29 | 阅读权限:游客 | 会员币:0 | 【

这个是近期常遇见的一个问题题,大意是这样的:

有一个总表,总表中包含N行标题列与M行数据,要将其中一列数据(比如A列)中相同值对应的行,分配到新工作表中。

如果数据量少的话,我们可以用筛选,再将结果复制到新工作表来完成,但数据一多,我们还是用VBA来完成吧:)。

首先,选择标题最后一行与条件数据所在列的单元格,比如共有3行标题,按第二列分配数据,就选择B3格,然后运行下面的宏:

Sub 按某列相同的值分到各工作表中()
On Error Resume Next
Dim I As Integer, N As Integer
Dim SR As Integer, ER As Integer, FC As Integer
Dim TS As String, SS As String
Dim OS As Worksheet, NS As Worksheet, KS As Worksheet
Set OS = ActiveSheet
FC = ActiveCell.Column
SR = ActiveCell.Row + 1
ER = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
For I = SR To ER
    TS = Cells(I, FC)
    If WorksheetFunction.CountIf(Range(Cells(SR, FC), Cells(I, FC)), TS) = 1 Then
        Set NS = ActiveWorkbook.Worksheets.Add(after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
        N = 0
        Do
            If N Then
                SS = TS & "(" & N & ")"
            Else
                SS = TS
            End If
            Set KS = Worksheets(SS)
            If KS Is Nothing Then
                NS.Name = SS
                Exit Do
            Else
                Set KS = Nothing
            End If
            N = N + 1
        Loop
        OS.Select
        Rows(SR - 1).Select
        Selection.AutoFilter
        Selection.AutoFilter Field:=FC, Criteria1:=TS
        ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy
        NS.Select
        ActiveSheet.Paste
        OS.Select
        Selection.AutoFilter
    End If
Next
Cells(SR - 1, FC).Select
Application.ScreenUpdating = True
End Sub

运行宏后的结果——生成的工作表以数据为名称,如果存在,则为原来的名称加“(N)”,工作表按原来的顺序排列在最后。附上实例(包含上面的宏)按某列相同的值分到各工作表中.rar

最后是格式问题,宏生成的表,行高与列宽都变了,如果需要设定格式:

1、设定列宽:
选择原总表,复制,再选择所有生成的工作表,最后用选择性粘贴——列宽即可。
2、设定标题的行高:
选择原总表的标题,复制,再选择所有生成的工作表,选择标题列,再粘贴,就处理完了。

这不?是不是又快又省事呀!

文章录入:admin | 浏览次数:
相关评论(以下网友评论只代表其个人观点,不代表Excel吧的观点或立场)
相关信息

关于本站 | 留言本站 | 友情连接 | 后台管理
Copyright © 2005 - 2008 Excel吧 Inc. All Rights Reserved.
HxCms Ver9.0  闽ICP备06001689号
关闭此窗口