不情之请求助excelhome的各位大侠，不知是否有好的vba方法帮助我分拆文件

围脖的部落格

mjzxlmg 发表于 2013-3-15 16:23
用邮件合并不好吗？

没有用过啊，适用于我的这个需求吗？

mjzxlmg

你是要每个人打印一张表格吗？　调查表在ＷＯＲＤ中做好，然后邮件合并生成所有人的表格

mavin

总体设计不对！应该就做1张统一的表。首先选择填表人（下拉列表，裴富才、王瑞华...）
D列是第1被评人，E列是第2被评人......，具体是那个被评人，通过VLOOKUP提取过来。
这样，只需要做一张统一的表发下去就可以了。填表的人，选择一下自己的名字就ok了，填起来也方便，一个sheet上。而且也科学，如果我要给10个人打分，我肯定是横向打分的，同一项目，10个人一起打完。
汇总也方便，你只要把这个sheet（名称固定）的内容提取出来。可以用vba实现。如果做成楼主设计的那样，sheet名都不固定，vba汇总起来又麻烦了。
如果还要实现打完分以后，都需要打印签字。那需要做一个打印的sheet，使用vlookup提取过来再打印。

Chip_Kenny

我将空白表加到此档
想您可能要每一人给一个档案,我把每张独立保存在此文件我所在位置上
接Alt+F8 run CC

hnwxm

看看如何。。。

grf1973

Sub wbadd()
    Dim wb As Workbook
    Dim ShtName As String
    Dim nRow, nCol, i, j As Integer
    nRow = ThisWorkbook.Sheets("名单").Range("A65536").End(xlUp).Row
    Application.DisplayAlerts = False
    For i = 2 To nRow
        Set wb = Workbooks.Add
        nCol = ThisWorkbook.Sheets("名单").Cells(i, 1).End(xlToRight).Column    '工作表数
            For j = 3 To nCol
                ShtName = Trim(ThisWorkbook.Sheets("名单").Cells(i, j).Text) '工作表名
                If Len(ShtName) > 0 Then
                    ThisWorkbook.Sheets("空白表").Copy after:=wb.Worksheets(Worksheets.Count)
                    ActiveSheet.Name = ShtName
                End If
            Next
            wb.Sheets("Sheet1").Delete
            wb.Sheets("Sheet2").Delete
            wb.Sheets("Sheet3").Delete
        wb.SaveAs ThisWorkbook.Path & "\成员表\" & Trim(ThisWorkbook.Sheets("名单").Cells(i, 1).Text) & ".xls"
        wb.Close
    Next
    Application.DisplayAlerts = True
End Sub

grf1973

先把空白评测表拷到名单表中命名为＂空白表＂，在当前目录新建文件夹＂成员表＂

ctp_119

1. Private Sub CommandButton1_Click()
   
2. Dim ir As Integer
   
3. Dim i As Integer
   
4. Dim bk As Workbook
   
5. Dim sh As Worksheet
   
6. Dim j As Integer
   
7. Dim str As String
   
8. Dim s As Integer
   
9. Dim ar As Variant
   
10. ir = [a65536].End(xlUp).Row
    
11. For i = 2 To ir
    
12.     str = Cells(i, 1)
    
13.     s = Range("iv" & i).End(xlToLeft).Column
    
14.     arr = Application.WorksheetFunction.Transpose(Range("c" & i).Resize(1, s - 2))
    
15.     Sheets("模板").Copy
    
16.     For j = 1 To s - 2
    
17.         Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
    
18.         sh.Name = arr(j, 1)
    
19.         Sheets("模板").Range("a1:e66").Copy sh.Range("a1")
    
20.     Next j
    
21.     Application.ActiveWorkbook.SaveAs (ThisWorkbook.Path & "/" & str)
    
22.     Application.ActiveWorkbook.Close True
    
23. Next i
    
24. End Sub
    

复制代码

ctp_119

终于好了，呵呵，我调试了好久，才成功！！！一键完成。具体情况请看附件。