表拆分到不同工作表

fansch

各位大神，工作表分类拆分到工作表，拆分后标题排序不同，如何编写代码，请各位大神帮我

fzxba

1. Sub test2() 'ADO + SQL
   
2.   Dim Conn As Object, rs As Object, SQL As String, sStr As String
   
3.   Dim wks As Worksheet, ar, titleRow As Long, splitCol As Long
   
4.   titleRow = 1  '标题所在 行
   
5.   splitCol = 5  '拆分依据 E列
   
6.   DoApp False
   
7.   Worksheets("Sheet1").Activate
   
8.   For Each wks In Worksheets
   
9.     If wks.Name <> ActiveSheet.Name Then wks.Delete
   
10.   Next
    
11.   Set Conn = CreateObject("ADODB.Connection")
    
12.   Set rs = CreateObject("ADODB.Recordset")
    
13.   If Application.Version < 12 Then
    
14.     Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    
15.   Else
    
16.     Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    
17.   End If
    
18.   ar = Range("A1").CurrentRegion.Resize(titleRow)
    
19.   sStr = ActiveSheet.Name & "$" & Range("A1").CurrentRegion.Offset(titleRow - 1).Address(0, 0)
    
20.   SQL = "SELECT DISTINCT [" & ar(titleRow, splitCol) & "] FROM [" & sStr & "] WHERE LEN([" & ar(titleRow, splitCol) & "])"
    
21.   rs.Open SQL, Conn, 1, 3
    
22.   SQL = "SELECT 序号,名称,规格,数量 FROM [" & sStr & "] WHERE [" & ar(titleRow, splitCol) & "]='[sStr]'"
    
23.   While Not rs.EOF
    
24.     sStr = rs.Fields(0).Value
    
25.     Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sStr
    
26.     With ActiveSheet
    
27.       .Range("A1").Resize(, 4) = Split("序号 名称 规格 数量")
    
28.       .Range("A" & titleRow + 1).CopyFromRecordset Conn.Execute(Replace(SQL, "[sStr]", sStr))
    
29.       '.Columns.AutoFit
    
30.     End With
    
31.     rs.MoveNext
    
32.   Wend
    
33.   rs.Close
    
34.   Set rs = Nothing
    
35.   Conn.Close
    
36.   Set Conn = Nothing
    
37.   Worksheets(1).Activate
    
38.   DoApp
    
39.   Beep
    
40. End Sub
    
41. 
    
42. Function DoApp(Optional b As Boolean = True)
    
43.   With Application
    
44.     .ScreenUpdating = b
    
45.     .DisplayAlerts = b
    
46.     .Calculation = -b * 30 - 4135
    
47.   End With
    
48. End Function

复制代码

ykcbf1100

看你是新人，提醒你一下，求助要上传附件的。附件必须压缩后才能上传。

fansch

ykcbf1100 发表于 2024-2-21 16:41
看你是新人，提醒你一下，求助要上传附件的。附件必须压缩后才能上传。

谢谢，怪不得，我上传附件的时候 老显示格式不对，所以就只能截图了

fzxba

拆分.rar (23.72 KB, 下载次数: 17)

2024-2-21 16:56 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.21
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("Sheet1")
   
9.     For Each sht In Sheets
   
10.         If sht.Name <> sh.Name Then
    
11.             sht.Delete
    
12.         End If
    
13.     Next
    
14.     arr = sh.[a1].CurrentRegion
    
15.     For i = 2 To UBound(arr)
    
16.         s = arr(i, 5)
    
17.         If Not d.Exists(s) Then
    
18.             Set d(s) = CreateObject("scripting.dictionary")
    
19.         End If
    
20.         d(s)(i) = i
    
21.     Next i
    
22.     b = [{1,2,5,4}]
    
23.     For Each k In d.keys
    
24.         Set sht = ws.Sheets.Add(after:=ws.Sheets(ws.Sheets.Count))
    
25.         m = 0
    
26.         ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2))
    
27.         With sht
    
28.             .Name = k
    
29.             .[a1:d1] = Array("序号", "名称", "规格", "数量")
    
30.             For Each kk In d(k).keys
    
31.                 m = m + 1
    
32.                 brr(m, 1) = m
    
33.                 For j = 2 To UBound(arr, 2)
    
34.                     brr(m, j) = arr(kk, j)
    
35.                 Next
    
36.             Next
    
37.             .[a2].Resize(m, 4) = brr
    
38.             With .[a1].Resize(m + 1, 4)
    
39.                 .Borders.LineStyle = 1
    
40.                 .HorizontalAlignment = xlCenter
    
41.                 .VerticalAlignment = xlCenter
    
42.             End With
    
43.         End With
    
44.     Next k
    
45.     sh.Activate
    
46.     Set d = Nothing
    
47.     Application.DisplayAlerts = True
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
50. End Sub
    

复制代码

lizhipei78

拆分不求人
https://club.excelhome.net/thread-1681303-1-1.html

fansch

fzxba 发表于 2024-2-21 16:56

谢谢

fansch

ykcbf1100 发表于 2024-2-21 17:05
参与一下。。。

谢谢