怎样把一张总表分成不同的分页？

frontall

如图所示，有没有办法用宏的方式实现按代理把数据分成不同的分页（或新文件）。

frontall

跪求解决方案啊。。。。

719404338

1. Sub t()
   
2. Dim arr, i%, j%, k%
   
3. m = 3
   
4. For j = 2 To 5
   
5. i = 1
   
6. arr = Range("a1:f" & [a65536].End(3).Row)
   
7. Sheets(j).Activate
   
8. For k = 1 To UBound(arr)
   
9. If arr(k, m) <> "" Then
   
10. Sheets(j).Range("a" & i) = arr(k, 1)
    
11. Sheets(j).Range("b" & i) = arr(k, 2)
    
12. Sheets(j).Range("c" & i) = arr(k, m)
    
13. i = i + 1
    
14. End If
    
15. Next k
    
16. m = m + 1
    
17. Next j
    
18. End Sub

复制代码

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("数据")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
9.     arr = .Range("a1").Resize(r, c)
   
10.     For j = 4 To UBound(arr, 2)
    
11.       For i = 1 To UBound(arr)
    
12.         If Len(arr(i, j)) <> 0 Then
    
13.           If Not d.exists(arr(1, j)) Then
    
14.             Set d(arr(1, j)) = .Range("a1:b1")
    
15.           End If
    
16.           Set d(arr(1, j)) = Union(d(arr(1, j)), .Cells(i, 1).Resize(1, 2))
    
17.         End If
    
18.       Next
    
19.     Next
    
20.   End With
    
21.   For Each aa In d.keys
    
22.     On Error Resume Next
    
23.     Set ws = Worksheets(aa)
    
24.     If Err Then
    
25.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
26.       ws.Name = aa
    
27.     End If
    
28.     On Error GoTo 0
    
29.     With Worksheets(aa)
    
30.       .Cells.Clear
    
31.       d(aa).Copy .Range("a1")
    
32.     End With
    
33.   Next
    
34. End Sub
    

复制代码

chxw68

详见附件。

iwangyi

Sub ADO()
Application.DisplayAlerts = False
For Each SH In Sheets
If SH.Name <> "数据" Then SH.Delete
Next
Set CN = CreateObject("adodb.connection")
CN.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
Sql = "SELECT * FROM [数据$A1:G]"
Set RS = CN.Execute(Sql)
For I = 3 To RS.FIELDS.Count - 1
BM = RS.FIELDS(I).Name
With Sheets.Add(AFTER:=Sheets(Sheets.Count))
[A1:B1].Copy .[A1:B1]: .[C1] = BM
.Name = BM
SQLL = "SELECT 料号,品牌," & BM & " FROM [数据$A1:G] WHERE " & BM & " IS NOT NULL"
.[A2].CopyFromRecordset CN.Execute(SQLL)
End With
Next
End Sub

iwangyi

附件请参考

浠朢↘恠明兲

数组/字典/SQL三版本都上了，可以好好学习一下·~
3楼感觉如果数据多会不会慢~~~