根据某列拆分成一个个xls文件，并统计

whlbliss

根据某列（如附件中的A列）的数值，将电子表格拆分成以不重复的数值命名的电子簿xls(如附件中的A列，生成小王.xls、小东.xls  
                             . ，


小张.xls),并统计每个电子簿的数值部分（求平均值和求和）

拆分表格.rar (1.59 KB, 下载次数: 22)

2017-3-20 19:36 上传

点击文件名下载附件

lsc900707

按列拆分的实例比比皆是>>>>>>>>

jiminyanyan

按列拆分搜索一下…………。

whlbliss

关键是还要统计

whlbliss

whlbliss 发表于 2017-3-20 19:43
关键是还要统计

网上的资料很丰富，但我的要求有两个，一是  “命名”   要求，二是  “统计”   要求。

lsc900707

whlbliss 发表于 2017-3-20 19:51
网上的资料很丰富，但我的要求有两个，意思  “命名”   要求，而是  “统计”   要求。

这是拆分成工作表的，有你要求的统计，你自己另存工作簿，可以吗？

1. Private Sub CommandButton1_Click()
   
2.     Dim tim1 As Date, tim2 As Date: tim1 = Timer
   
3.     Dim arr, d As Object, sht As Worksheet
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = [a1].CurrentRegion
   
6.     For i = 1 To UBound(arr)
   
7.         If Not d.exists(arr(i, 1)) Then
   
8.             Set d(arr(i, 1)) = Range("a" & i).Resize(1, 5)
   
9.         Else
   
10.             Set d(arr(i, 1)) = Union(d(arr(i, 1)), Range("a" & i).Resize(1, 5))
    
11.         End If
    
12.     Next
    
13.     x = d.keys
    
14.     For k = 1 To UBound(x)
    
15.         Set sht = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
    
16.         sht.Name = x(k)
    
17.         d.items()(k).Copy sht.Range("a" & 2)
    
18.         Rows("1:1").Copy sht.[a1]
    
19.     Next
    
20.     For Each sht In Sheets
    
21.         If sht.Name <> "Sheet1" Then
    
22.            With sht
    
23.               k = .Cells(.Rows.Count, 1).End(xlUp).Row
    
24.               arr = .[a1].CurrentRegion
    
25.               For i = 2 To UBound(arr)
    
26.                   For j = 3 To UBound(arr, 2)
    
27.                      If IsNumeric(.Cells(i, j)) Then
    
28.                          .Cells(k + 1, 1) = "平均": .Cells(k + 2, 1) = "合计"
    
29.                          .Cells(k + 1, j) = Application.Average(Application.Index(arr, , j))
    
30.                          .Cells(k + 2, j) = Application.Sum(Cells(i, j).Resize(i - 1, 1))
    
31.                      End If
    
32.                   Next
    
33.               Next
    
34.             End With
    
35.         End If
    
36.     Next
    
37.     tim2 = Timer
    
38.     MsgBox Format(tim2 - tim1, "拆分完成，共耗时：0.00秒"), 64, "时间统计"
    
39. End Sub

复制代码

lsc900707

whlbliss 发表于 2017-3-20 19:51
网上的资料很丰富，但我的要求有两个，一是  “命名”   要求，二是  “统计”   要求。

这是拆分成工作表的，有你要求的统计，你自己另存工作簿，可以吗？
Private Sub CommandButton1_Click()
    Dim tim1 As Date, tim2 As Date: tim1 = Timer
    Dim arr, d As Object, sht As Worksheet
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = Range("a" & i).Resize(1, 5)
        Else
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), Range("a" & i).Resize(1, 5))
        End If
    Next
    x = d.keys
    For k = 1 To UBound(x)
        Set sht = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
        sht.Name = x(k)
        d.items()(k).Copy sht.Range("a" & 2)
        Rows("1:1").Copy sht.[a1]
    Next
    For Each sht In Sheets
        If sht.Name <> "Sheet1" Then
           With sht
              k = .Cells(.Rows.Count, 1).End(xlUp).Row
              arr = .[a1].CurrentRegion
              For i = 2 To UBound(arr)
                  For j = 3 To UBound(arr, 2)
                     If IsNumeric(.Cells(i, j)) Then
                         .Cells(k + 1, 1) = "平均": .Cells(k + 2, 1) = "合计"
                         .Cells(k + 1, j) = Application.Average(Application.Index(arr, , j))
                         .Cells(k + 2, j) = Application.Sum(Cells(i, j).Resize(i - 1, 1))
                     End If
                  Next
              Next
            End With
        End If
    Next
    tim2 = Timer
    MsgBox Format(tim2 - tim1, "拆分完成，共耗时：0.00秒"), 64, "时间统计"
End Sub

jiminyanyan

1. Sub 保留表头拆分数据为若干新工作簿()
   
2.     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
   
3.     c = Application.InputBox("请输入拆分列号", , 1, , , , , 1)
   
4.     If c = 0 Then Exit Sub
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     arr = [a1].CurrentRegion
   
8.     lc = UBound(arr, 2)
   
9.     Set rng = [a1].Resize(, lc)
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     For i = 2 To UBound(arr)
    
12.         If Not d.Exists(arr(i, c)) Then
    
13.             Set d(arr(i, c)) = Cells(i, 1).Resize(1, lc)
    
14.         Else
    
15.             Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
    
16.         End If
    
17.     Next
    
18.     k = d.Keys
    
19.     t = d.Items
    
20.     For i = 0 To d.Count - 1
    
21.         With Workbooks.Add(xlWBATWorksheet)
    
22.             rng.Copy .Sheets(1).[a1]
    
23.             t(i).Copy .Sheets(1).[a2]
    
24.             lr = .Sheets(1).Cells(65536, 1).End(xlUp).Row
    
25.             .Sheets(1).Cells(lr + 1, 1) = "合计"
    
26.             .Sheets(1).Cells(lr + 1, 3) = WorksheetFunction.Sum(.Sheets(1).Range("c2:c" & lr))
    
27.             .Sheets(1).Cells(lr + 1, 4) = WorksheetFunction.Sum(.Sheets(1).Range("d2:d" & lr))
    
28.             .Sheets(1).Cells(lr + 1, 5) = WorksheetFunction.Sum(.Sheets(1).Range("e2:e" & lr))
    
29.             .SaveAs Filename:=ThisWorkbook.Path & "" & k(i) & ".xls"
    
30.             .Close
    
31.         End With
    
32.     Next
    
33.     Application.DisplayAlerts = True
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "完毕"
    
36. End Sub

复制代码

jiminyanyan

.............

jiminyanyan

whlbliss 发表于 2017-3-20 19:51
网上的资料很丰富，但我的要求有两个，一是  “命名”   要求，二是  “统计”   要求。

两个简单的零件，自己组装一下…………