费用汇总按月拆分

rainbrige10

各位大侠，请帮忙，能否按月将每个月的费用划分到各月的标签内，比如说费用汇总内1月的就把整行的信息都放到1月的标签内，谢谢了

新纪元

副本费用.rar (177.29 KB, 下载次数: 11)

2017-3-29 14:57 上传

点击文件名下载附件

利用透视表 显示报表筛选页功能

lsc900707

按列拆分数据，先找找相关帖子参考。

rainbrige10

lsc900707 发表于 2017-3-29 15:10
按列拆分数据，先找找相关帖子参考。

我觉得我这个应该是按行拆分吧

rainbrige10

新纪元 发表于 2017-3-29 14:59
利用透视表 显示报表筛选页功能

这个是已经汇总了，我要拆分成跟汇总表格式一样的

rainbrige10

请各位大神帮忙

lsc900707

rainbrige10 发表于 2017-3-29 15:34
这个是已经汇总了，我要拆分成跟汇总表格式一样的

Sub lsc()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set d = CreateObject("scripting.dictionary")
  With Sheet1
    arr = .UsedRange
    For i = 2 To UBound(arr)
      s = Month(arr(i, 1))
      If Not d.exists(s) Then
        Set d(s) = .[a1:h1]
      End If
      Set d(s) = Union(d(s), .Cells(i, 1).Resize(1, 8))
    Next
  End With
  For Each sht In Worksheets
    If sht.Name <> "费用汇总" Then
      sht.Delete
    End If
  Next
  For Each c In d.keys
    Set sht = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    With sht
        For j = 1 To UBound(arr, 2)
           .Columns(j).ColumnWidth = Sheet1.Columns(j).ColumnWidth
        Next
       .Name = CStr(c) & "月"
        d(c).Copy .[a1]
    End With
  Next
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

lsc900707

1. Sub lsc()
   
2.   Application.ScreenUpdating = False
   
3.   Application.DisplayAlerts = False
   
4.   Set d = CreateObject("scripting.dictionary")
   
5.   With Sheet1
   
6.     arr = .UsedRange
   
7.     For i = 2 To UBound(arr)
   
8.       s = Month(arr(i, 1))
   
9.       If Not d.exists(s) Then
   
10.         Set d(s) = .[a1:h1]
    
11.       End If
    
12.       Set d(s) = Union(d(s), .Cells(i, 1).Resize(1, 8))
    
13.     Next
    
14.   End With
    
15.   For Each sht In Worksheets
    
16.     If sht.Name <> "费用汇总" Then
    
17.       sht.Delete
    
18.     End If
    
19.   Next
    
20.   For Each c In d.keys
    
21.     Set sht = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
22.     With sht
    
23.         For j = 1 To UBound(arr, 2)
    
24.            .Columns(j).ColumnWidth = Sheet1.Columns(j).ColumnWidth
    
25.         Next
    
26.        .Name = CStr(c) & "月"
    
27.         d(c).Copy .[a1]
    
28.     End With
    
29.   Next
    
30.   Application.ScreenUpdating = True
    
31.   Application.DisplayAlerts = True
    
32. End Sub

复制代码

rainbrige10

lsc900707 发表于 2017-3-29 17:28

谢谢大师了，还有个请求，能帮我把这个表也按照月拆分成工作表么……另外如果可能的话按照费用承担人写个拆分的代码，多谢

rainbrige10

lsc900707 发表于 2017-3-29 17:28

多谢大师，非常好用