按日期字段拆分多个excel表格

yamkoo

求助各位老师：

      最近在统计表格，需要根据“日期”字段，在同一个excel文件下，将总表按照每一天拆成一个个工作簿，每个工作簿的名称以日期命名，该怎么处理？）？

样表请见附件。

yamkoo

不好意思，是工作表，按附件的格式。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim ws As Worksheet
   
5.   Dim d As Object
   
6.   Dim d1 As Object
   
7.   Application.ScreenUpdating = False
   
8.   Application.DisplayAlerts = False
   
9.   Set d = CreateObject("scripting.dictionary")
   
10.   Set d1 = CreateObject("scripting.dictionary")
    
11.   With Worksheets("初始表格")
    
12.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.     arr = .Range("c1:c" & r)
    
14.     For i = 2 To UBound(arr)
    
15.       If Not d.exists(arr(i, 1)) Then
    
16.         Set d(arr(i, 1)) = .Range("a1").Resize(1, 9)
    
17.       End If
    
18.       Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 9))
    
19.     Next
    
20.   End With
    
21.   For Each ws In Worksheets
    
22.     d1(ws.Name) = ""
    
23.   Next
    
24.   For Each aa In d.keys
    
25.     wjm = Format(aa, "yyyy-mm-dd")
    
26.     If Not d1.exists(wjm) Then
    
27.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
28.       ws.Name = wjm
    
29.     End If
    
30.     With Worksheets(wjm)
    
31.       .Cells.Clear
    
32.       d(aa).Copy .Range("a1")
    
33.     End With
    
34.   Next
    
35. End Sub
    
36. 
    

复制代码

chxw68

详见附件。

七彩屋

1. Sub 按C列日期拆分到不同工作表中()
   
2. Application.ScreenUpdating = False
   
3. Dim brr()
   
4. Dim dic As Object
   
5. Set dic = CreateObject("scripting.dictionary")
   
6. arr = Worksheets("初始表格").[a1].CurrentRegion
   
7.     For i = 2 To UBound(arr, 1)
   
8.         nam = arr(i, 3)
   
9.         nam = Format(nam, "m.dd")
   
10.         If dic.exists(nam) = False Then
    
11.             dic(nam) = ""
    
12.             Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = nam
    
13.             Worksheets(nam).[a1].Resize(1, UBound(arr, 2)) = arr
    
14.         End If
    
15.         ReDim brr(1 To UBound(arr, 2))
    
16.         For k = 1 To UBound(brr)
    
17.             brr(k) = arr(i, k)
    
18.         Next
    
19.         Worksheets(nam).[a65536].End(xlUp).Offset(1, 0).Resize(1, UBound(brr)) = brr
    
20.     Next
    
21. Application.ScreenUpdating = True
    
22. End Sub

复制代码

按日期拆分表格0612.rar (20.64 KB, 下载次数: 48)

2015-6-12 10:38 上传

点击文件名下载附件

看见星光

1. Sub lianxi()
   
2. Dim arr, brr(), d, sht As Worksheet
   
3. Dim hrow&, wrow&, j&, str, myrow&
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6.     For Each sht In Worksheets
   
7.         If Not sht Is ActiveSheet Then sht.Delete
   
8.     Next
   
9. arr = [a1].CurrentRegion
   
10. i = UBound(arr, 1)
    
11. wrow = UBound(arr, 2)
    
12. Set d = CreateObject("scripting.dictionary")
    
13.     For j = 2 To i
    
14.         d(arr(j, 3)) = ""
    
15.     Next
    
16.     For Each str In d.keys
    
17.         Set sht = Worksheets.Add(, Worksheets(Sheets.Count))
    
18.         sht.Name = Application.Text(str, "m.d") & "（完成结果 " & sht.Index - 1 & ")"
    
19.         For j = 1 To i
    
20.             If arr(j, 3) = str Then
    
21.                 k = k + 1
    
22.                 ReDim Preserve brr(1 To wrow, 1 To k)
    
23.                     For myr = 1 To wrow
    
24.                         brr(myr, k) = arr(j, myr)
    
25.                     Next
    
26.             End If
    
27.         Next
    
28.         Sheets(1).[a1:i6].Copy sht.[a1]
    
29.         sht.[a2].Resize(k, wrow) = Application.Transpose(brr)
    
30.         Erase brr
    
31.         k = 0
    
32.     Next
    
33. Application.ScreenUpdating = True
    
34. Application.DisplayAlerts = True
    
35. End Sub
    

复制代码