Excel 如何把总表根据条件自动拆分成工作表

zorsite

在拆分之前我想问一句：
你确定要把所有表格拆分出来吗？应该有168张表。拆分容易，以后如果你想要统计其他信息的话，从这168张表中提取数据又够你忙一阵了。

1. Sub 拆分()
   
2. lastrow = [a65536].End(xlUp).Row
   
3. arr = Range("A1:A" & lastrow)
   
4. startrow = 3
   
5. For i = 1 To lastrow
   
6.     If Trim(arr(i, 1)) = "合计" Then '通过"合计"来判断从哪一行开始拆分
   
7.         Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
   
8.         Range("A1:L2").Copy sht.Range("A1")
   
9.         Range("A" & startrow).Resize(i - startrow + 1, 12).Copy sht.Range("A3")
   
10.         startrow = i + 1
    
11.     End If
    
12. Next
    
13. End Sub
    

复制代码

huangtianci

这个是只生产了工作表吗  大哥有没有宏可以加上内容的

huangtianci

zorsite 发表于 2017-12-13 16:10
在拆分之前我想问一句：
你确定要把所有表格拆分出来吗？应该有168张表。拆分容易，以后如果你想要统计其 ...

这个是只拆分了工作表吗  大哥有没有宏可以加上内容的

huangtianci

小花鹿 发表于 2017-12-13 11:08
分两次复制，先复制表头，再复制户信息，在这之前先新建工作表

大哥 能帮做个宏吗 非常感谢

zorsite

huangtianci 发表于 2017-12-13 16:49
大哥 能帮做个宏吗 非常感谢

有这会时间你都能把代码看懂……看你这工作职责估计以后少不了要天天和excel打交道。
房地产评估.rar (159.58 KB, 下载次数: 128)

2017-12-13 17:19 上传

点击文件名下载附件

乐乐2006201505

在11楼的基础上，合并了同名内容，共60多个工作表。

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
lastrow = [a65536].End(xlUp).Row
arr = Range("A1:A" & lastrow)
startrow = 3
For i = 1 To lastrow
    If Trim(arr(i, 1)) = "合计" Then
        d(arr(startrow, 1)) = i
        startrow = i + 1
    End If
Next
k = d.keys
For m = 0 To d.Count - 1
    Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
    sht.Name = k(m)
Next
startrow = 3
For i = 1 To lastrow
    If Trim(arr(i, 1)) = "合计" Then '通过"合计"来判断从哪一行开始拆分
        If d.exists(arr(startrow, 1)) Then
            Set sht = Sheets(arr(startrow, 1))
            If sht.Range("A3") = "" Then
                Range("A1:L2").Copy sht.Range("A1")
                Range("A" & startrow).Resize(i - startrow + 1, 12).Copy sht.Range("A3")
                startrow = i + 1
            Else
                Range("A" & startrow).Resize(i - startrow + 1, 12).Copy sht.Range("A" & sht.Range("a65536").End(3).Row)
                startrow = i + 1
            End If
        End If
    End If
Next
Application.ScreenUpdating = True
End Sub

LMY123

保留2行标题，根据合计字符拆分工作表

huangtianci

zorsite 发表于 2017-12-13 17:21
有这会时间你都能把代码看懂……看你这工作职责估计以后少不了要天天和excel打交道。

感谢大哥！！！！非常好用！！！！谢谢！！！！

huangtianci

乐乐2006201505 发表于 2017-12-13 23:06
在11楼的基础上，合并了同名内容，共60多个工作表。

Private Sub CommandButton1_Click()

大哥 能不能按照11楼那种代码的方式发出来下  我复制了一下 好像不显示  是不是代码格式不对啊

乐乐2006201505

huangtianci 发表于 2017-12-14 11:10
大哥 能不能按照11楼那种代码的方式发出来下  我复制了一下 好像不显示  是不是代码格式不对啊

1. Private Sub CommandButton1_Click()
   
2. Application.ScreenUpdating = False
   
3. Dim d As Object
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. lastrow = [a65536].End(xlUp).Row
   
6. arr = Range("A1:A" & lastrow)
   
7. startrow = 3
   
8. For i = 1 To lastrow
   
9.     If Trim(arr(i, 1)) = "合计" Then
   
10.         d(arr(startrow, 1)) = i
    
11.         startrow = i + 1
    
12.     End If
    
13. Next
    
14. k = d.keys
    
15. For m = 0 To d.Count - 1
    
16.     Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
    
17.     sht.Name = k(m)
    
18. Next
    
19. startrow = 3
    
20. For i = 1 To lastrow
    
21.     If Trim(arr(i, 1)) = "合计" Then '通过"合计"来判断从哪一行开始拆分
    
22.         If d.exists(arr(startrow, 1)) Then
    
23.             Set sht = Sheets(arr(startrow, 1))
    
24.             If sht.Range("A3") = "" Then
    
25.                 Range("A1:L2").Copy sht.Range("A1")
    
26.                 Range("A" & startrow).Resize(i - startrow + 1, 12).Copy sht.Range("A3")
    
27.                 startrow = i + 1
    
28.             Else
    
29.                 Range("A" & startrow).Resize(i - startrow + 1, 12).Copy sht.Range("A" & sht.Range("a65536").End(3).Row)
    
30.                 startrow = i + 1
    
31.             End If
    
32.         End If
    
33.     End If
    
34. Next
    
35. Application.ScreenUpdating = True
    
36. End Sub

复制代码

为了实现多次点击按钮不出错，已将代码优化，请下载附件运行即可。望看到代码的高手可以优化我的代码，尤其是8-18句。