多列条件拆分代码求助

灵犀之声

各位老师好，求助一个拆分的代码：

1.源数据
按源数据DEF三列为条件进行拆分为独立工作簿。
2.拆分好的工作簿命名以D-E-F命名
3.拆分出来的工作簿删除DEF列

求助各位大佬，我对公式函数略知一二，对代码一窍不通，拜谢各位大佬，小花花奉上！！！

灵犀之声

求助论坛各位大佬。鲜花感谢

baofa2

1. Sub test1()
   
2.   Dim ar, dict As Object, titleRow As Long, splitCol As Long
   
3.   Dim strPath As String, strKey As String, colSize As Long, i As Long
   
4. 
   
5.   Application.ScreenUpdating = False
   
6. 
   
7.   titleRow = 1
   
8. '  splitCol = 5
   
9. 
   
10.   strPath = ThisWorkbook.Path & "\分簿\"
    
11.   If Dir(strPath, vbDirectory) = "" Then MkDir strPath
    
12. 
    
13.   Set dict = CreateObject("Scripting.Dictionary")
    
14.   With Worksheets("出库单明细导入")
    
15.     ar = .Range("A1").CurrentRegion
    
16.     colSize = UBound(ar, 2)
    
17.     For i = titleRow + 1 To UBound(ar)
    
18.       strKey = Trim(ar(i, 4)) & "-" & Trim(ar(i, 5)) & "-" & Trim(ar(i, 6))
    
19.       If Len(strKey) Then
    
20.         If Not dict.Exists(strKey) Then Set dict(strKey) = .Range("A1").Resize(titleRow, colSize)
    
21.         Set dict(strKey) = Union(dict(strKey), .Cells(i, 1).Resize(, colSize))
    
22.       End If
    
23.     Next
    
24.   End With
    
25. 
    
26.   Application.DisplayAlerts = False
    
27.   For i = 0 To dict.Count - 1
    
28.     With Workbooks.Add
    
29.       With .Worksheets(1)
    
30.         .Name = dict.Keys()(i)
    
31.         dict.Items()(i).Copy .Range("A1")
    
32.         .DrawingObjects.Delete
    
33.         .Columns.AutoFit
    
34.       End With
    
35.       .SaveAs strPath & dict.Keys()(i), 51
    
36.       .Close
    
37.     End With
    
38.   Next
    
39. 
    
40.   Set dict = Nothing
    
41. 
    
42.   Application.DisplayAlerts = True
    
43.   Application.ScreenUpdating = True
    
44.   Beep
    
45. End Sub
    

复制代码

沈默00

字典拆分就不写了，函数的写一个

沈默00

其实就是按D列拆分，

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, dic As Object, vKey, strFileName$, strPath$, rngHeader As Range

    DoApp False
    Set dic = CreateObject("Scripting.Dictionary")
    With [A1].CurrentRegion
        ar = .Value
        Set rngHeader = .Rows(1)
        For i = 2 To UBound(ar)
            strFileName = ar(i, 4) & "-" & ar(i, 5) & "-" & ar(i, 6)
            If Not dic.exists(strFileName) Then
                Set dic(strFileName) = rngHeader
            End If
            Set dic(strFileName) = Union(dic(strFileName), .Rows(i))
        Next
    End With
   
    strPath = ThisWorkbook.Path & "\分表\"
    If Dir(strPath, vbDirectory) = "" Then MkDir strPath
   
    For Each vKey In dic.keys
        strFileName = strPath & vKey
        With Workbooks.Add
            dic(vKey).Copy
            .Sheets(1).[A1].PasteSpecial xlPasteColumnWidths
            dic(vKey).Copy .Sheets(1).[A1]
            .SaveAs strFileName
            .Close
        End With
    Next
   
    Set dic = Nothing: Set rngHeader = Nothing
    DoApp
    Beep
End Sub
Function DoApp(Optional b As Boolean = True)
    With Application
        .ScreenUpdating = b
        .DisplayAlerts = b
        .Calculation = -b * 30 - 4135
    End With
End Function

gwjkkkkk

请参考附件。。。

灵犀之声

baofa2 发表于 2024-5-7 17:51

感谢老师，但是能不能帮我改一下，新拆分出来的要删除DEF三列。

灵犀之声

沈默00 发表于 2024-5-7 18:02
字典拆分就不写了，函数的写一个

老师，函数可以拆分成独立的工作簿吗？

灵犀之声

沈默00 发表于 2024-5-7 18:03
其实就是按D列拆分，

老师，您的没有代码