谁能帮我把一个execl表格的数据提取分成三个execl表格

rszmyc

我有一个execl表格数据很多，谁能帮我把一个execl表格的数据提取分成三个execl表格，要是能直接转换成三个独立的DBF(dbase)文件更好。

rszmyc

要是能直接转生成三个独立的DBF(dbase)文件更好

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Brr, Crr, m&, n&, j&, r%, Arr1()
   
3. Dim d, Drr, jj&, k, t, l&
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. Arr = Sheet1.[a1].CurrentRegion
   
7. ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2) - 1)
   
8. ReDim Crr(1 To UBound(Arr), 1 To 8)
   
9. ReDim Drr(1 To UBound(Arr), 1 To 5)
   
10. For i = 4 To UBound(Arr)
    
11.     If Arr(i, 1) <> "" And Arr(i, 2) <> "" Then
    
12.         n = n + 1
    
13.         Brr(n, 2) = Replace(Arr(i, 2), "-", "00")
    
14.         For j = 1 To 3 Step 2
    
15.             Brr(n, j) = Arr(i, j)
    
16.         Next
    
17.         For j = 5 To UBound(Arr, 2)
    
18.             Brr(n, j - 1) = Arr(i, j)
    
19.         Next
    
20.         r = r + 1
    
21.         ReDim Preserve Arr1(1 To r)
    
22.         Arr1(r) = i
    
23.     End If
    
24. Next
    
25. With Sheet2
    
26.     .[a4:i5000].ClearContents
    
27.     .[a4:i5000].Borders.LineStyle = xlNone
    
28.     .[a4].Resize(n, UBound(Brr, 2)) = Brr
    
29.     .[a4].Resize(n, UBound(Brr, 2)).Borders.LineStyle = 1
    
30. End With
    
31. For i = 1 To r
    
32.     If i <> r Then
    
33.         js = Arr1(i + 1) - 1
    
34.     Else
    
35.         js = UBound(Arr) - 2
    
36.     End If
    
37.     ks = Arr1(i)
    
38.     For j = ks + 1 To js
    
39.         m = m + 1
    
40.         Crr(m, 1) = Arr(ks, 1)
    
41.         Crr(m, 2) = Replace(Arr(ks, 2), "-", "00")
    
42.         Crr(m, 3) = Arr(ks, 3)
    
43.         For jj = 4 To 8
    
44.             Crr(m, jj) = Arr(j, jj - 1)
    
45.         Next
    
46.     Next
    
47. Next
    
48. With Sheet3
    
49.     .[a4:h5000].ClearContents
    
50.     .[a4:h5000].Borders.LineStyle = xlNone
    
51.     .[a4].Resize(m, UBound(Crr, 2)) = Crr
    
52.     .[a4].Resize(m, UBound(Crr, 2)).Borders.LineStyle = 1
    
53. End With
    
54. For i = 1 To UBound(Crr)
    
55.     If Not d.exists(Crr(i, 4)) Then d(Crr(i, 4)) = i
    
56. Next
    
57. k = d.keys: t = d.items
    
58. For i = 0 To UBound(k)
    
59.     Drr(i + 1, 1) = Crr(t(i), 1)
    
60.     Drr(i + 1, 2) = k(i)
    
61.     For j = 6 To 8
    
62.         Drr(i + 1, j - 3) = Crr(t(i), j)
    
63.     Next
    
64. Next
    
65. With Sheet4
    
66.     .[a4:e5000].ClearContents
    
67.     .[a4:e5000].Borders.LineStyle = xlNone
    
68.     .[a4].Resize(d.Count, UBound(Drr, 2)) = Drr
    
69.     .[a4].Resize(d.Count, UBound(Drr, 2)).Borders.LineStyle = 1
    
70. End With
    
71. End Sub
    

复制代码

蓝桥玄霜

请见附件。

rszmyc

你好，请看这个，，，前面少了两列，后面少了三列，生成的三个表格还是原来的那样，，，应该怎么改啊 含量分析.zip (583.95 KB, 下载次数: 10)

2014-4-30 22:05 上传

点击文件名下载附件

rszmyc

蓝桥玄霜 发表于 2014-4-29 09:53
请见附件。

先看一下，谢谢了。。。

rszmyc

蓝桥玄霜 发表于 2014-4-29 09:53
请见附件。

你好，帮我看看这个怎么实现有多少人就打印多少张