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

whlbliss

lsc900707 发表于 2017-3-20 20:01
这是拆分成工作表的，有你要求的统计，你自己另存工作簿，可以吗？
Private Sub CommandButton1_Click() ...

谢谢您的代码，能成功拆分成表，但提示 For i = 2 To UBound(arr)  类型不匹配

活在理想的世界

1. Option Explicit
   
2. Sub D()
   
3. Application.DisplayAlerts = False
   
4. Dim D As New Dictionary
   
5. Dim I, K, X As Integer
   
6. Dim 路径 As String
   
7. Dim N As Worksheet
   
8. Dim SHT As Worksheet
   
9. Dim A()
   
10. Dim B()
    
11. Set N = ActiveSheet
    
12. K = N.Range("A32767").End(xlUp).Row
    
13. A = N.Range("A2:A" & K)
    
14. For I = LBound(A) To UBound(A)
    
15.     D(A(I, 1)) = ""
    
16. Next
    
17. B = WorksheetFunction.Transpose(D.Keys)
    
18. For I = LBound(B) To UBound(B)
    
19.     Sheets.Add AFTER:=Sheets(Sheets.Count)
    
20.     Sheets(Sheets.Count).Name = B(I, 1)
    
21. Next
    
22. N.Select
    
23. For Each SHT In Sheets
    
24.     If SHT.Name <> N.Name Then
    
25.         N.Range("A1:E" & K).AutoFilter FIELD:=1, Criteria1:=SHT.Name
    
26.         N.Range("A1:E" & K).Copy SHT.Range("A1")
    
27.         X = SHT.Range("A32767").End(xlUp).Row
    
28.         SHT.Range("A" & X + 1) = "合计"
    
29.         SHT.Range("C" & X + 1) = WorksheetFunction.Sum(SHT.Range("C:C"))
    
30.         SHT.Range("D" & X + 1) = WorksheetFunction.Sum(SHT.Range("D:D"))
    
31.         SHT.Range("E" & X + 1) = WorksheetFunction.Sum(SHT.Range("E:E"))
    
32.     End If
    
33. Next
    
34. N.Range("A1:E" & K).AutoFilter
    
35. 100
    
36. 路径 = InputBox("请输入路径")
    
37. If 路径 = "" Then
    
38.     GoTo 100
    
39. End If
    
40. For Each SHT In Sheets
    
41.     If SHT.Name <> N.Name Then
    
42.         SHT.Copy
    
43.         ActiveWorkbook.SaveAs Filename:=路径 & SHT.Name & ".xls"
    
44.         ActiveWorkbook.Close
    
45.     End If
    
46. Next
    
47. For Each SHT In Sheets
    
48.     If SHT.Name <> N.Name Then
    
49.         SHT.Delete
    
50.     End If
    
51. Next
    
52. Application.DisplayAlerts = True
    
53. End Sub
    

复制代码

whlbliss

jiminyanyan 发表于 2017-3-20 20:07
两个简单的零件，自己组装一下…………

非常感谢，但我是菜鸟，不知道在哪里赏花。还请赐教。学会了赏花，以后就能感谢更多的好心人。

whlbliss

lsc900707 发表于 2017-3-20 20:01
这是拆分成工作表的，有你要求的统计，你自己另存工作簿，可以吗？
Private Sub CommandButton1_Click() ...

谢谢您的代码，让我茅塞顿开！

lsc900707

whlbliss 发表于 2017-3-20 20:24
非常感谢，但我是菜鸟，不知道在哪里赏花。还请赐教。学会了赏花，以后就能感谢更多的好心人。

帖子右下角点击“评分”就可以了。

jiminyanyan

whlbliss 发表于 2017-3-20 20:24
非常感谢，但我是菜鸟，不知道在哪里赏花。还请赐教。学会了赏花，以后就能感谢更多的好心人。

花就算了，没什么用处………………。

lsc900707

whlbliss 发表于 2017-3-20 20:10
谢谢您的代码，能成功拆分成表，但提示 For i = 2 To UBound(arr)  类型不匹配

代码放数据工作表代码区就行，按钮用activex 控件按钮，我测试没问题。
这是另存工作簿的，能保持列宽不变：
Private Sub CommandButton1_Click()
    Set rng = Range("a1:e1")
    Application.ScreenUpdating = False
    arr = Range("a1:e" & Range("a65536").End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
         If Not d.exists(arr(i, 1)) Then
                Set d(arr(i, 1)) = Cells(i, 1).Resize(1, 5)
            Else
                Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 5))
         End If
    Next
    k = d.keys: t = d.items
    For x = 0 To d.Count - 1
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb.Sheets(1)
            rng.Copy .[a1]: t(x).Copy .[A2]
            arr = .[a1].CurrentRegion
            n = .Cells(65536, 1).End(xlUp).Row
            For m = 3 To UBound(arr, 2)
                If IsNumeric(.Cells(n, m)) Then
                    .Cells(n + 1, 1) = "平均": .Cells(n + 2, 1) = "合计"
                    .Cells(n + 1, m) = Application.Average(Application.Index(arr, , m))
                    .Cells(n + 2, m) = Application.Sum(Cells(n, m).Resize(n - 1, 1))
                    .Columns(m).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(m).ColumnWidth
                End If
            Next
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k(x), FileFormat:=xlExcel8
        wb.Close
    Next
    Application.ScreenUpdating = True
    Set rng = Nothing: Set wb = Nothing
    MsgBox "完毕"
End Sub

lsc900707

whlbliss 发表于 2017-3-20 20:10
谢谢您的代码，能成功拆分成表，但提示 For i = 2 To UBound(arr)  类型不匹配

1. Private Sub CommandButton1_Click()
   
2.     Set rng = Range("a1:e1")
   
3.     Application.ScreenUpdating = False
   
4.     arr = Range("a1:e" & Range("a65536").End(xlUp).Row)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For i = 2 To UBound(arr)
   
7.          If Not d.exists(arr(i, 1)) Then
   
8.                 Set d(arr(i, 1)) = Cells(i, 1).Resize(1, 5)
   
9.             Else
   
10.                 Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 5))
    
11.          End If
    
12.     Next
    
13.     k = d.keys: t = d.items
    
14.     For x = 0 To d.Count - 1
    
15.         Set wb = Workbooks.Add(xlWBATWorksheet)
    
16.         With wb.Sheets(1)
    
17.             rng.Copy .[a1]: t(x).Copy .[A2]
    
18.             arr = .[a1].CurrentRegion
    
19.             n = .Cells(65536, 1).End(xlUp).Row
    
20.             For m = 3 To UBound(arr, 2)
    
21.                 If IsNumeric(.Cells(n, m)) Then
    
22.                     .Cells(n + 1, 1) = "平均": .Cells(n + 2, 1) = "合计"
    
23.                     .Cells(n + 1, m) = Application.Average(Application.Index(arr, , m))
    
24.                     .Cells(n + 2, m) = Application.Sum(Cells(n, m).Resize(n - 1, 1))
    
25.                     .Columns(m).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(m).ColumnWidth
    
26.                 End If
    
27.             Next
    
28.         End With
    
29.         wb.SaveAs Filename:=ThisWorkbook.Path & "" & k(x), FileFormat:=xlExcel8
    
30.         wb.Close
    
31.     Next
    
32.     Application.ScreenUpdating = True
    
33.     Set rng = Nothing: Set wb = Nothing
    
34.     MsgBox "完毕"
    
35. End Sub

复制代码

yeminqiang

模块3的代码


拆分表格.zip (20.18 KB, 下载次数: 13)

2017-3-20 21:41 上传

点击文件名下载附件

znsong

阿打算打打。