将表内的每行拆分为单独的EXCEL文件并且保留第二个SHEET

driveyin

求助各位大神，
Sub SplitExl()
Application.DisplayAlerts = False '新建的文档存在时，不发送警示，覆盖式保存
Dim lngRs&, lngCs&, cx&, strEndCl$
Dim topR(), EveryR(), oExl As Object, oWk As Workbook
Dim strPath$
strPath = ThisWorkbook.Path & "\"
With ActiveSheet.UsedRange
lngRs = .Rows.Count
lngCs = .Columns.Count
End With
strEndCl = Replace(Replace(Cells(1, lngCs).Address, "$", ""), "1", "")
topR = Range("A1:" & strEndCl & "1") '数据标题行
For cx = 2 To lngRs
EveryR = Range("A" & Format(cx) & ":" & strEndCl & Format(cx)) '把每行记录放入数组
Set oWk = Application.Workbooks.Add
With oWk
'.Parent.Visible = True
With .Sheets(1)
.Range("A1:" & strEndCl & "1") = topR '把标题行放入另建的工作薄
.Range("A2:" & strEndCl & "2") = EveryR '把单个记录放入同一另建的工作薄
End With
.SaveAs Filename:=strPath & EveryR(1, 7) & ".xls" '以每行A列记录为工作薄名称
.Close
End With
Next
Set oWk = Nothing
Set oExl = Nothing
Erase topR: Erase EveryR
Application.DisplayAlerts = True
End Sub



通过这个代码可以拆分表内每行，但是我的工作薄里还有一个SHEET2需要复制到拆分的表里（同样是SHEET2），在这个代码基础上怎么实现

不知道为什么

写了这么多，不如一个附件来的直接！相信没几个人想去看你的代码

jiminyanyan

上附件。。。。

driveyin

不知道为什么 发表于 2018-7-12 19:06
写了这么多，不如一个附件来的直接！相信没几个人想去看你的代码

大神我上传啦

driveyin

jiminyanyan 发表于 2018-7-12 20:39
上附件。。。。

附件来啦，麻烦大神帮忙看看

driveyin

有大神帮忙看看吗？感谢

wolfmare

源代码有错误，懒得调试了，你自己处理吧，

1. With .Sheets(1)
   
2. .Range("A1:" & strEndCl & "1") = topR '把标题行放入另建的工作薄
   
3. .Range("A2:" & strEndCl & "2") = EveryR '把单个记录放入同一另建的工作薄
   
4. End With
   
5. ThisWorkbook.Sheets(2).Copy after:=oWk.Sheets(Worksheets.Count)
   
6. .SaveAs Filename:=strPath & EveryR(1, 7) & ".xls" '以每行A列记录为工作薄名称
   
7. .Close
   

复制代码

在save前面加一行就可以了

LMY123

driveyin 发表于 2018-7-13 08:54
有大神帮忙看看吗？感谢

1. Sub ADO加字典()
   
2.     Dim dq, sh, sql$, conn As Object, i&, j&
   
3.     dq = [a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(dq)
   
6.       d(dq(i, 7)) = ""
   
7.     Next
   
8.     k = d.keys
   
9.     sh = Array("填报表", "自动生成清查表") '等待拆分的表
   
10.     arr = Array("a2:am") '区域
    
11.     brr = Array("7") ''字段
    
12.     crr = Array("2") '行
    
13.     Set conn = CreateObject("adodb.connection")
    
14.     conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=" & ThisWorkbook.FullName
    
15.     Application.ScreenUpdating = False
    
16.     For i = 0 To UBound(k)
    
17.         Sheets(sh).Copy ''//复制所有工作表
    
18.         For j = 0 To UBound(sh) - 1
    
19.                 With ActiveWorkbook.Sheets(j + 1)
    
20.                     .UsedRange.Offset(crr(j) - 1, 0).ClearContents
    
21.                     sql = "select * from [" & sh(j) & "$" & arr(j) & "] where f" & brr(j) & "='" & k(i) & "'"    ''起始位置4
    
22.                     .Cells(crr(j), 1).CopyFromRecordset conn.Execute(sql)
    
23.                 End With
    
24.         Next
    
25.         ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & k(i) & ".xlsx"
    
26.         ActiveWorkbook.Close
    
27.     Next
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "ok!"
    
30. End Sub

复制代码

driveyin

wolfmare 发表于 2018-7-13 09:13
源代码有错误，懒得调试了，你自己处理吧，

谢谢大神！！！可以了

driveyin

wolfmare 发表于 2018-7-13 09:13
源代码有错误，懒得调试了，你自己处理吧，

大神我的代码里拆分后的文件都显示同一条内容，能不能帮我看一下