求助：一个工作根据某列拆分多个工作表，每个工作表有N个sheet

学习真好啊

一个工作根据某列拆分多个工作表，每个工作表有N个sheet；每个sheet拆分的那列名称一样但是列可能不固定

fzxba

测试.zip (25.95 KB, 下载次数: 10)

2024-3-22 17:18 上传

点击文件名下载附件

fzxba

1. Sub test1() '另一法 测试
   
2.   Dim ar, Cel As Range, Dict As Object, i As Long, j As Long, k
   
3.   Dim Conn As Object, SQL As String, p As String, strKeyword As String
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   p = ThisWorkbook.Path & "\分簿\"
   
7.   If Dir(p, vbDirectory) = "" Then MkDir p
   
8.   'p = p & "\"
   
9.   Set Dict = CreateObject("Scripting.Dictionary")
   
10.   ReDim br(1 To Worksheets.Count) As String
    
11.   ReDim cr(1, 1 To Worksheets.Count) As String
    
12.   strKeyword = "客户名称"
    
13.   For j = 1 To Worksheets.Count
    
14.     With Worksheets(j)
    
15.       Set Cel = .Cells.Find(strKeyword, , , 1)
    
16.       ar = .Range(Cel, .Cells(.Rows.Count, Cel.Column).End(xlUp))
    
17.       For i = 2 To UBound(ar)
    
18.         k = Trim(ar(i, 1))
    
19.         If Len(k) Then If Not Dict.Exists(k) Then Dict.Add k, vbNullString
    
20.       Next
    
21.       br(j) = .Name
    
22.       cr(0, j) = Cel.Row + Cel.MergeArea.Rows.Count
    
23.       With .Range("A1").CurrentRegion
    
24.         cr(1, j) = "SELECT * FROM [" & br(j) & "$" & Intersect(.Offset(0), .Offset(cr(0, j))).Address(0, 0) & "] WHERE F" & Cel.Column & "="
    
25.       End With
    
26.     End With
    
27.   Next
    
28.   Set Cel = Nothing
    
29.   Set Conn = CreateObject("ADODB.Connection")
    
30.   Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
    
31.   For Each k In Dict.Keys
    
32.     Worksheets(br).Copy
    
33.     With ActiveWorkbook
    
34.       For j = 1 To UBound(br)
    
35.         With .Worksheets(br(j))
    
36.           .DrawingObjects.Delete
    
37.           .UsedRange.Offset(cr(0, j) - 1).ClearContents
    
38.           .Cells(cr(0, j), "A").CopyFromRecordset Conn.Execute(cr(1, j) & "'" & k & "'")
    
39.         End With
    
40.       Next
    
41.       .SaveAs p & k, 51
    
42.       .Close
    
43.     End With
    
44.   Next
    
45.   Conn.Close
    
46.   Set Conn = Nothing
    
47.   Set Dict = Nothing
    
48.   Application.DisplayAlerts = True
    
49.   Application.ScreenUpdating = True
    
50.   Beep
    
51. End Sub

复制代码

学习真好啊

fzxba 发表于 2024-3-22 17:31

谢谢，我运行了一下提示这个错误

fzxba

学习真好啊 发表于 2024-3-22 17:44
谢谢，我运行了一下提示这个错误

针对附件这里没问题的.zip (31.45 KB, 下载次数: 16)

2024-3-22 17:47 上传

点击文件名下载附件

确认无误后上传，前面的不行？

补充一下，若WPS，方法2用不了。

学习真好啊

fzxba 发表于 2024-3-22 17:18

这个测试OK，谢谢

lizhipei78

就是对每个工作簿的每个工作表按列进行拆分成单独的工作簿是不？
不需要对同样的客户进行合并，然后再根据客户名称汇总成一个工作簿是吧。

ykcbf1100

参与一下，用字典做一个。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.23
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set ws = ThisWorkbook
   
7.     For Each sht In Sheets
   
8.         With sht
   
9.             r = .Cells(Rows.Count, 1).End(3).Row
   
10.             c = .UsedRange.Columns.Count
    
11.             c1 = Application.WorksheetFunction.Match("客户名称", .Rows(1), 0)
    
12.             arr = .[a1].Resize(r, c)
    
13.         End With
    
14.         For i = 2 To UBound(arr)
    
15.             s = arr(i, c1)
    
16.             d(s) = ""
    
17.         Next
    
18.     Next
    
19.     On Error Resume Next
    
20.     For Each k In d.keys
    
21.         ws.Sheets.Copy
    
22.         Set wb = ActiveWorkbook
    
23.         For Each sht In wb.Sheets
    
24.             m = 0
    
25.             With sht
    
26.                 r = .Cells(Rows.Count, 1).End(3).Row
    
27.                 c = .UsedRange.Columns.Count
    
28.                 c1 = Application.WorksheetFunction.Match("客户名称", .Rows(1), 0)
    
29.                 arr = .[a1].Resize(r, c)
    
30.                 ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
31.                 For i = 2 To UBound(arr)
    
32.                     s = arr(i, c1)
    
33.                     If s = k Then
    
34.                         m = m + 1
    
35.                         For j = 1 To UBound(arr, 2)
    
36.                             brr(m, j) = arr(i, j)
    
37.                         Next
    
38.                     End If
    
39.                 Next
    
40.                 .UsedRange.Offset(1) = ""
    
41.                 .DrawingObjects.Delete
    
42.                 .[a2].Resize(m, UBound(arr, 2)) = brr
    
43.             End With
    
44.         Next
    
45.         wb.SaveAs p & k
    
46.         wb.Close
    
47.     Next
    
48.     Set d = Nothing
    
49.     Application.ScreenUpdating = False
    
50.     MsgBox "OK！"
    
51. End Sub
    
52. 
    

复制代码

ykcbf1100

练手，换个写法