要求按模板格式实现数据按行拆分新建工作表

阿囡123

求大师帮忙，万分感谢
具体资料见附件，用VBA功能实现，谢谢大师帮忙，

yaojil

文件结构稍有改动

opiona

数据.rar (28.79 KB, 下载次数: 25)

2018-6-18 21:23 上传

点击文件名下载附件

opiona

1. 
   
2.     PATHM = ThisWorkbook.Path & "\简历模板.XLS"  '//外部模板
   
3. 
   
4.     Set SHX = Worksheets("员工资料")
   
5.     PathG = ThisWorkbook.Path & "\员工简历"  '//结果文件夹
   
6.     Set FSO = CreateObject("Scripting.FileSystemObject")
   
7.     If FSO.FolderExists(PathG) = True Then
   
8.         FSO.GetFolder(PathG).Delete   '//删除文件夹
   
9.     End If
   
10.     MkDir PathG    '//创建文件夹
    
11.    
    
12.     Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
    
13.    
    
14.     Rem  模板中放置数据的单元格位置，和查询标题对应
    
15.     StrWZ = ""
    
16.     StrWZ = StrWZ & "B2,D2,F2,B3,D3,F3,B4,D4,F4"
    
17.     StrWZ = StrWZ & ",B5,F5,B6,F6,B7"
    
18.     BRX = Split(StrWZ, ",")
    
19.     StrBT = ""
    
20.     StrBT = StrBT & "[姓名],[年龄],[性别],[籍贯],[民族],[学历],[健康],[身高],[体重]"
    
21.     StrBT = StrBT & ",[身份证号码],[政治面貌],[联系方式],[婚姻状况],[现居住地]"
    
22.    
    
23.    
    
24.     Rem  先获取要拆分字段的不重复值
    
25.     StrSQL = "SELECT DISTINCT [身份证号码]"
    
26.     StrSQL = StrSQL & " FROM [" & SHX.Name & "$A1:IT]"
    
27.     StrSQL = StrSQL & " WHERE NOT [身份证号码] IS NULL AND LEN([身份证号码])>0"
    
28.     ARX = GET_SQL_To_Arr(StrSQL, Str_coon, False)  '//不重复姓名放入二维数组
    
29.    
    
30.     If ARX(0, 0) <> "" And ARX(0, 0) <> "Error" Then
    
31.         ICINT = UBound(ARX) + 1
    
32.         
    
33.         For X = 0 To ICINT - 1 '//循环每一个值
    
34.             Rem  提示信息，在状态栏显示
    
35.             Application.StatusBar = "需拆分总数：" & ICINT & " 个，当前是第：" & X + 1 & " 个，当前身份证号码是：" & ARX(X, 0)
    
36.             DoEvents
    
37.             
    
38.             Rem 查询对应数据
    
39.             StrSQL = ""
    
40.             StrSQL = StrSQL & "SELECT TOP 1 " & StrBT
    
41.             StrSQL = StrSQL & " FROM [" & SHX.Name & "$A1:IT]"
    
42.             StrSQL = StrSQL & " WHERE [身份证号码]='" & ARX(X, 0) & "'"
    
43.             SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
44.             
    
45.             If SQLARR(0, 0) <> "" And SQLARR(0, 0) <> "Error" Then '//没有数据，不保存
    
46.                
    
47.                 Set WB = Workbooks.Open(PATHM)
    
48.                 Set SHW = WB.Worksheets(1)
    
49.                 SHW.Name = SQLARR(0, 0) & "_" & ARX(X, 0)
    
50.                
    
51.                 Rem =============================================================按对应位置放置,数组和标题对应
    
52.                 For ICOL = 0 To UBound(BRX)
    
53.                     SHW.Range("" & BRX(ICOL)).Value = SQLARR(0, ICOL)
    
54.                 Next
    
55.                
    
56.                 WB.SaveAs Filename:=PathG & "" & SQLARR(0, 0) & "_" & ARX(X, 0) & ".XLS", FileFormat:=xlExcel8
    
57.                 WB.Close True
    
58.             End If
    
59.         Next
    
60.     Else
    
61.         MsgBox "未发现拆分依据 需要的值！", vbInformation, "北极狐提示!!"
    
62.     End If

复制代码

阿囡123

opiona 发表于 2018-6-18 21:23

非常感谢大师，但是有个功能没有实现，就是数据导入“个人简历”模板中，在保存之前打印出来一份，再保存，请大师，这个代码怎么写，谢谢

opiona

阿囡123

opiona 发表于 2018-6-19 10:43

非常感谢大师，希望大师再百忙中，抽出时间帮我一下，谢谢，非常感谢你

yaojil

插入相片 单独实现