Sub s() arr = [a1].CurrentRegion Set d = CreateObject(＂scripting.dictionary＂) For i = 2 To UBound(arr) a = Left(arr(i, 2), 2) If d.exists(a) Then n = Sheets(a).Cells(Rows..

Sub t() Application.ScreenUpdating = False On Error Resume Next With Worksheets(＂Sheet1＂) For i = 2 To .[E65536].End(xlUp).Row nam = .Cells(i, ＂E＂) If Worksheets(.

用数据透视表 再看看别人怎么说的.

楼主可以用这两个小程序,试试看,理论上来达到你要的效果.第一步:首先用“直接拆分大表”的程序,将大表sheet1拆分为多个新工作薄.第二步:还是用＂直接拆分大表＂的程序,将sheet2拆分为多个新工作表在源大表中.第三步:最后用“将一个工作薄中的多个(或是一个)工作表匹配复制到多个工作薄中”将源大表中的拆分sheet2得到的新工作表,复制到第一步折分sheet1得到的多个工作薄中.第四步:拆分sheet3,就是重复第二步到第三步.

看样子是遇到空行就提取为一列吧,这样的代码你是否满意呢:sub 数组分列() dim arr,i,j,m,n n=cells(rows.count,1).end(xlup).row 'a列最后一行位置 arr=cells(1,1).resize(n,1) '把a列有效内容存入数组 j=4 '从4列开始保存数据 i=1 while i＂＂ n=n+1 wend cells(i,1).resize(n,1).copy cells(1,j) '复制列 j=j+1 '下一列 m=n+1 '下一行 wendend sub

将所选择的工作薄中的所有工作表拆成单独的工作薄http://www.xipick/forum.php?mod=viewthread&tid=440814&fromuid=1手动选择需要拆分的工作薄,比如选择的工作薄名为“需要拆分的工作薄甲”,把该工作薄里面的所有工作表都拆分成单独的工作薄,并以其工作表的名称做为新工作薄名称,存放在本工作薄所在目录下面的名称为“拆分-需要拆分的工作薄甲-得到的工作薄”的文件夹中.1、首先要选择是否需要拆分后的工作表数值化.2、其次选择需要拆分的工作薄.只能选择一个.

所有工作表都不重名吗?Sub 文件拆分() Application.ScreenUpdating = False p = ＂C:\源文件夹\＂ '源文件存放的路径,根据实际修改 f = Dir(p & ＂*.xls＂) Do While f .

sub 列数据转文件() dim twork as workbook, tsht as worksheet, namedic, endrow . = false then range(＂a1:c1＂).autofilter'将工作表a1:c1区域设置为自动筛选,按自己需.

很简单的,不过建议用分列

既然不追问,则直接贴代码吧 Sub 工作簿拆分() Dim wb As Workbook, sh As Worksheet For Each sh In Worksheets '遍历所有工作表 sh.Copy '复制工作表 Set wb = ActiveWorkbook '到新的工作簿 k = k + 1 '计数 '注:此行也可写成k=sh.name 如果这样写,则下行中汉字去掉. wb.SaveAs ThisWorkbook.Path & ＂/第＂ & k & ＂个表.xls＂ '在本文件路径中保存工作簿 wb.Close '关闭创建的工作簿 Next End Sub