求助：将excel表中相同内容拆分到工作簿里去。试过很多代码都失败了。求助啊

office小白鼠

求助：本人想将excel表中相同内容拆分到每个工作簿去。试过很多代码都失败了。求助啊将附件中的内容用代码拆分成如下图那样就好了。先多谢各位大神了。


拆分附件.rar (7.78 KB, 下载次数: 5)

2018-7-17 18:56 上传

点击文件名下载附件

office小白鼠

麻烦各位大神抽空过来露两手，谢谢！用这个代码拆分附件没有反应，但是也不报错。其余我试过很多代码，都报错。这个代码和我的要求很接近，但是我不知道那里有问题，表示看不懂。
Sub 拆分()
  Dim i%, r%
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim d As Object
  Dim sp As Shape
  Set d = CreateObject("scripting.dictionary")
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  With Worksheets("RRU网络割接专用模板")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("b1:b" & r)
    For i = 6 To UBound(arr)
      If Not d.exists(arr(i, 1)) Then
        Set d(arr(i, 1)) = .Range("a1:q5")
      End If
      Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 17))
    Next
  End With
  Application.SheetsInNewWorkbook = 1
  For Each aa In d.keys
    Set wb = Workbooks.Add
    With wb
      With .Worksheets("RRU网络割接专用模板")
        d(aa).Copy .Range("a1")
        .Name = aa
        For Each sp In .Shapes
          sp.Delete
        Next
      End With
      .SaveAs Filename:=ThisWorkbook.path & "\" & aa & ".xls", FileFormat:=xlExcel8
      .Close False
    End With
  Next
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

chaohuahch

这种案例，论坛里面很多。你随便一搜，都应该一堆。

jiminyanyan

拆分的例子是很多．．．

chxw68

1. Sub 拆分()
   
2.   Dim i%, r%
   
3.   Dim wb As Workbook
   
4.   Dim ws As Worksheet
   
5.   Dim d As Object
   
6.   Dim sp As Shape
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Application.DisplayAlerts = False
   
9.   Application.ScreenUpdating = False
   
10.   With Worksheets("RRU网络割接专用模板")
    
11.     r = .Cells(.Rows.Count, 10).End(xlUp).Row
    
12.     arr = .Range("j1:j" & r)
    
13.     For i = 5 To UBound(arr)
    
14.       If Not d.exists(arr(i, 1)) Then
    
15.         Set d(arr(i, 1)) = .Range("a1:ab4")
    
16.       End If
    
17.       Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 28))
    
18.     Next
    
19.   End With
    
20.   Application.SheetsInNewWorkbook = 1
    
21.   For Each aa In d.keys
    
22.     Set wb = Workbooks.Add
    
23.     With wb
    
24.       With .Worksheets(1)
    
25.         d(aa).Copy .Range("a1")
    
26.         .Name = aa
    
27.         For Each sp In .Shapes
    
28.           sp.Delete
    
29.         Next
    
30.       End With
    
31.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa, FileFormat:=xlExcel8
    
32.       .Close False
    
33.     End With
    
34.   Next
    
35.   Application.ScreenUpdating = True
    
36.   Application.DisplayAlerts = True
    
37. End Sub
    

复制代码

chxw68

楼主2楼找见的代码好像是我写的。

jiminyanyan

chu老师代码OK。。。。

office小白鼠

chaohuahch 发表于 2018-7-17 19:18
这种案例，论坛里面很多。你随便一搜，都应该一堆。

案例是很多，但是对于小白来说：那就是一个字母加一个字母，具体是什么意思？能表达出什么？短时间根本弄不明白。隔行如隔山，，，我试了一下午的代码，也尝试去修改代码，但这些知识都需要累计。

office小白鼠

jiminyanyan 发表于 2018-7-17 19:33
拆分的例子是很多．．．

案例是很多，但是对于小白来说：那就是一个字母加一个字母，具体是什么意思？能表达出什么？短时间根本弄不明白。隔行如隔山，，，我试了一下午的代码，也尝试去修改代码，但这些知识都需要累计。