根据A列的姓名生成工作表名，保存其对应记录内容到给表中！！

kwzs_abc

刚才发的帖子没有找到，再发一次！！

我有一个excel工作表，我想实现：

1、以A列姓名生成对应的工作表名，并将其对应记录保存在该工作表中，新生成的工作表不要再出现姓名字段！！

2、以姓名生成的工作表名内的表头不要再出现姓名字段！！

不知这个想法能否实现，求高手帮助！！

我的这个工作表中有相同的记录！

Book2.rar (5.57 KB, 下载次数: 46)

2014-3-3 21:29 上传

点击文件名下载附件

zhaogang1960

ADO法请参考：

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object, i&, j&, SQL$, sh As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     For Each sh In Worksheets
   
6.         If sh.Name <> "Sheet1" Then sh.Delete
   
7.     Next
   
8.     Set cnn = CreateObject("ADODB.Connection")
   
9.     cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0;imex=1';Data Source =" & ThisWorkbook.FullName
   
10.     SQL = "select distinct 姓名 from [Sheet1$]"
    
11.     s = "select format(身份证,'000000000000000000') as 身份证," & Join([d1:t1&""], ",") & " from [Sheet1$] where 姓名='"
    
12.     arr = cnn.Execute(SQL).GetRows
    
13.     For j = 0 To UBound(arr, 2)
    
14.         Worksheets.Add(After:=Sheets(Sheets.Count)).Name = arr(0, j)
    
15.         SQL = s & arr(0, j) & "'"
    
16.         Set rs = cnn.Execute(SQL)
    
17.         For i = 1 To rs.Fields.Count
    
18.             Cells(1, i) = rs.Fields(i - 1).Name
    
19.         Next
    
20.         Range("a2").CopyFromRecordset rs
    
21.     Next
    
22.     rs.Close
    
23.     cnn.Close
    
24.     Set rs = Nothing
    
25.     Set cnn = Nothing
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    

复制代码

zhaogang1960

请测试附件
Book2.rar (34.47 KB, 下载次数: 171)

2014-3-3 23:14 上传

点击文件名下载附件

清风竹-

请测试一下做个参考。

kwzs_abc

清风竹- 发表于 2014-3-3 23:18
请测试一下做个参考。

谢谢！！下载来测试一下

kwzs_abc

zhaogang1960 发表于 2014-3-3 23:11
ADO法请参考：

没有试验成功！！请详细点！！谢谢！！有附件！！

kwzs_abc

zhaogang1960 发表于 2014-3-3 23:14
请测试附件

这个好像能行！在学习中！！

kwzs_abc

清风竹- 发表于 2014-3-3 23:18
请测试一下做个参考。

这个没达到目的，表中有相同多条姓名记录时时，执行时只能复制条啊，没有将所有记录复制到相应的表中

kwzs_abc

zhaogang1960 发表于 2014-3-3 23:11
ADO法请参考：

这是我在本论坛找到的一段代码：

Sub 按B列内容创建新表()
    On Error Resume Next     '忽略错误继续执行VBA代码,避免出现错误消息
    Dim mDic, mKey, i&, mArr
    mArr = Sheet1.Range("b2:b" & [b65536].End(xlUp).Row)
    Set mDic = CreateObject("Scripting.Dictionary")    '创建字典
    For i = 1 To UBound(mArr)    '循环字典内容
        mDic.Add mArr(i, 1), ""    '如果不为空则加入字典
    Next
   
    For Each mKey In mDic.keys    '读取字典
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = mKey    '放在最右边
    Next
On Error GoTo 0          '恢复正常的错误提示
End Sub


这段代码能够按B列姓名生成对应的工作表，就是无法将对应的记录（多条）保存在相应的工作表中！！

能否帮我改进一下，以实现自己的目的！！

等待中！！1

zhaogang1960

kwzs_abc 发表于 2014-3-4 11:47
这是我在本论坛找到的一段代码：

Sub 按B列内容创建新表()

如果附件中姓名没有重复，这个程序就可以，但实际上姓名有89个，不重复的只有54个