求助，vba实现数据拆分

58911126

根据"字段五"E列分单位拆分数据，将相同的单位数据放在同一个sheet中，分别建立单独的excel文件，需要保留原有单元格式

deweyfbi

你总的做一些模拟数据吧，这样帮你的人也好直接根据你需要做个代码什么的，就图片怎么弄的？

yeminqiang

看图写代码，不得少于800字符。

58911126

deweyfbi 发表于 2016-11-30 11:42
你总的做一些模拟数据吧，这样帮你的人也好直接根据你需要做个代码什么的，就图片怎么弄的？

哦哦哦不好意思，我用手机上传的不知道为什么附件只能加图片，压缩包上不来T-T

58911126

模拟数据已经上传，等大神

yeminqiang

1. Sub cdsr()
   
2.     Dim arr, brr(), i&, d As Object, ws As Worksheet, dd, j%, k&
   
3.     arr = Sheet1.[a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     ReDim brr(1 To UBound(arr), 1 To 7)
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     For Each ws In Worksheets
   
9.         If ws.Index > 1 Then
   
10.             ws.Delete
    
11.         End If
    
12.     Next
    
13.     For i = 2 To UBound(arr)
    
14.         d(arr(i, 5)) = ""
    
15.     Next
    
16.     For Each dd In d.keys
    
17.         Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
18.         ws.Name = dd
    
19.         For i = 2 To UBound(arr)
    
20.             If arr(i, 5) = dd Then
    
21.                 k = k + 1
    
22.                 For j = 1 To 7
    
23.                     brr(k, j) = arr(i, j)
    
24.                 Next
    
25.             End If
    
26.         Next
    
27.         ws.Range("a1:g1") = Array("字段1", "字段2", "字段3", "字段4", "字段5", "字段6", "字段7")
    
28.         ws.Range("a2").Resize(k, 7) = brr
    
29.         k = 0
    
30.     Next
    
31.     Sheet1.Select
    
32.     Application.DisplayAlerts = True
    
33.     Application.ScreenUpdating = True
    
34. End Sub
    

复制代码

yeminqiang

数据拆分.zip (30.23 KB, 下载次数: 20)

2016-11-30 15:54 上传

点击文件名下载附件