关于VBA拆分代码的疑问

wangxuchun

代码地址：http://club.excelhome.net/thread-398041-2-1.html（代码发布者：FDD）我用FDD发布的代码拆分了一个1-3行是表头的表格，输出的结果缺少内容。
Copy tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)
我把+1改为+3，输出内容完整，但每行之间又多加了2个空行，我不太了解VBA，请大家帮忙指点一下如何修改，谢谢！


Excel 数据列 为A-M，关键字在C列，表头为A1-M3区域。数据行起始行：4
根据关键字拆分工作簿（同时保留其他工作表、公式等）.rar (12.79 KB, 下载次数: 2)

2015-4-14 21:33 上传

点击文件名下载附件
含VBA，但不好使

完整代码：

1. Option Explicit
   
2. Sub addWK2()
   
3. Dim dic, temp, arr, tempWK, temp2
   
4. Dim rng As Range
   
5. Const BYSHNAME As String = "数据表" '可以修改根据哪一个工作表拆分工作簿
   
6. Application.ScreenUpdating = False
   
7. Set dic = CreateObject("scripting.dictionary") '字典
   
8. '下面一句代码：设置上面设置的工作表中的哪一列的内容拆分工作簿
   
9. Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("c4:c" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
   
10. For Each temp In rng.Cells '这个for循环实现该列的不重复值的筛选
    
11.     If Not dic.exists(temp.Value) Then
    
12.         dic.Add temp.Value, ""
    
13.     End If
    
14. Next
    
15. arr = dic.keys '返回此列不重复值的数组
    
16. 
    
17. For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿，并复制应有的内容
    
18.     ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "" & temp & ".xls" '以当前temp的值为新工作簿的名称，备份当前工作簿
    
19.    
    
20.    
    
21.    
    
22.     Set tempWK = Workbooks.Open(ThisWorkbook.Path & "" & temp & ".xls") '打开以temp的值为名称的工作簿
    
23.    
    
24.    
    
25.         
    
26.         tempWK.Sheets(BYSHNAME).Cells.Clear '清除该工作簿以BYSHNAME为名称的工作表的所有内容
    
27.    
    
28.     For Each temp2 In rng '这个for循环是比较源工作簿中拆分依据的工作表中，拆分依据的那一列与当前temp值是否相同，相同即复制相关内容
    
29.         If temp2 = temp Then
    
30.         '下面代码：temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy是复制源工作表的从A-D列的内容
    
31.         '代码tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)是获取tempWK工作簿以BYSHNAME为名称的工作表的最后列的下一行第一列的位置
    
32.             temp2.Offset(0, 1 - rng.Column).Resize(1, 13).Copy tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)
    
33.             
    
34.         End If
    
35.     Next
    
36.     ThisWorkbook.Sheets(BYSHNAME).Range("1:3").Copy tempWK.Sheets(BYSHNAME).Range("1:3") '复制标题栏
    
37.     tempWK.Save
    
38.     tempWK.Close
    
39. Next
    
40. Application.ScreenUpdating = True
    
41. Set dic = Nothing
    
42. Set rng = Nothing
    
43. ThisWorkbook.Sheets(1).Select
    
44. 
    
45.    
    
46.    
    
47. End Sub

复制代码

另，FDD发表的最后一个代码运行提示：应用程序定义或对象定义的错误。请大家帮忙查看一下是否有错误？

1. Option Explicit
   
2. Sub addWK2()
   
3.     Dim dic, temp, arr, tempWK, temp2
   
4.     Dim rng As Range
   
5.     Dim strArea As String
   
6.     Const BYSHNAME As String = "数据表" '可以修改根据哪一个工作表拆分工作簿
   
7.    
   
8.     Set dic = CreateObject("scripting.dictionary") '字典
   
9.     '下面一句代码：设置上面设置的工作表中的哪一列的内容拆分工作簿
   
10.     Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("c4:c" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
    
11.     For Each temp In rng.Cells '这个for循环实现该列的不重复值的筛选
    
12.         If Not dic.exists(temp.Value) Then
    
13.             dic.Add temp.Value, ""
    
14.         End If
    
15.     Next
    
16.    
    
17.     arr = dic.keys '返回此列不重复值的数组
    
18.    
    
19.    
    
20.     For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿，并删除不应有的内容
    
21.         ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "" & temp & ".xls" '以当前temp的值为新工作簿的名称，备份当前工作簿
    
22.         Set tempWK = Workbooks.Open(ThisWorkbook.Path & "" & temp & ".xls") '打开以temp的值为名称的工作簿
    
23.         strArea = "" '用于储存所有需要删除的行的地址字符串
    
24.         For Each temp2 In rng.Cells '这个for循环是比较源工作簿中拆分依据的工作表中，拆分依据的那一列与当前temp值是否相同，删除不相关内容
    
25.             If temp2 <> temp Then
    
26.                 If strArea <> "" Then
    
27.                     strArea = strArea & ","
    
28.                 End If
    
29.                 strArea = strArea & tempWK.Sheets(BYSHNAME).Cells(temp2.Row, temp2.Column).EntireRow.Address
    
30.             End If
    
31.         Next
    
32.         tempWK.Sheets(BYSHNAME).Range(strArea).Delete
    
33.         tempWK.Save
    
34.         tempWK.Close
    
35.     Next
    
36.    
    
37.     Set dic = Nothing
    
38.     Set rng = Nothing
    
39.     ThisWorkbook.Sheets(1).Select
    
40. End Sub

复制代码

jpj123

代码好长，建议你上传附件。

doitbest

略为修改
Sub addWK2()
Dim dic, temp, arr, tempWK, temp2
Dim rng As Range
Const BYSHNAME As String = "基本情况统计表" '可以修改根据哪一个工作表拆分工作簿
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary") '字典
'下面一句代码：设置上面设置的工作表中的哪一列的内容拆分工作簿
Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("c4:c" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
For Each temp In rng.Cells '这个for循环实现该列的不重复值的筛选
    If Not dic.exists(temp.Value) Then
        dic.Add temp.Value, ""
    End If
Next
arr = dic.keys '返回此列不重复值的数组
For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿，并复制应有的内容
    ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & temp & ".xls" '以当前temp的值为新工作簿的名称，备份当前工作簿
    Set tempWK = Workbooks.Open(ThisWorkbook.Path & "\" & temp & ".xls") '打开以temp的值为名称的工作簿
        tempWK.Sheets(BYSHNAME).[4:10000].Clear '清除该工作簿以BYSHNAME为名称的工作表的所有内容
    For Each temp2 In rng '这个for循环是比较源工作簿中拆分依据的工作表中，拆分依据的那一列与当前temp值是否相同，相同即复制相关内容
        If temp2 = temp Then
        '下面代码：temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy是复制源工作表的从A-D列的内容
        '代码tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)是获取tempWK工作簿以BYSHNAME为名称的工作表的最后列的下一行第一列的位置
            temp2.Offset(0, 1 - rng.Column).Resize(1, 13).Copy tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)
        End If
    Next
'    ThisWorkbook.Sheets(BYSHNAME).Range("1:3").Copy tempWK.Sheets(BYSHNAME).Range("1:1") '复制标题栏
    tempWK.Save
    tempWK.Close
Next
Application.ScreenUpdating = True
Set dic = Nothing
Set rng = Nothing
ThisWorkbook.Sheets(1).Select
End Sub

wangxuchun

doitbest 发表于 2015-4-15 09:04
略为修改
Sub addWK2()
Dim dic, temp, arr, tempWK, temp2

感谢大侠回复！谢谢。