多列条件拆分代码求助

灵犀之声

gwjkkkkk 发表于 2024-5-7 18:08
请参考附件。。。

老师，新拆分的不要DEF三列，怎么改一下呢，谢谢

baofa2

灵犀之声 发表于 2024-5-7 18:16
感谢老师，但是能不能帮我改一下，新拆分出来的要删除DEF三列。

灵犀之声

baofa2 发表于 2024-5-7 18:22

谢谢老师，成功

gwjkkkkk

灵犀之声 发表于 2024-5-7 18:22
老师，新拆分的不要DEF三列，怎么改一下呢，谢谢

baofa2老师帮你写了我不写了。。。

yanglinzi

1. Sub 拆分()
   
2. Dim arr, brr, i, j, r, d, n
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. Set d = CreateObject("scripting.dictionary")
   
6. p = ThisWorkbook.Path & "\分表"
   
7. With Sheet1
   
8.     r = .Cells(Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a1:i" & r)
   
10. End With
    
11. For i = 2 To UBound(arr)
    
12.     s = arr(i, 4) & "-" & arr(i, 5) & "-" & arr(i, 6)
    
13.     d(s) = d(s) & "," & i
    
14. Next
    
15. For Each k In d.keys
    
16.     n = 1
    
17.     xa = Split(d(k), ",")
    
18.     ReDim brr(1 To UBound(xa) + 1, 1 To 6)
    
19.     For i = 1 To UBound(xa)
    
20.         n = n + 1
    
21.         For j = 1 To 3
    
22.             brr(1, j) = arr(1, j)
    
23.             brr(n, j) = arr(xa(i), j)
    
24.         Next
    
25.         For jj = 7 To 9
    
26.             brr(1, jj - 3) = arr(1, jj)
    
27.             brr(n, jj - 3) = arr(xa(i), jj)
    
28.         Next
    
29.     Next
    
30.     Set wb = Workbooks.Add
    
31.     Set sh = wb.Sheets(1)
    
32.     With sh
    
33.     .[a:a,b:b,c:c,e:e,f:f].NumberFormatLocal = "@"
    
34.     .[a1].Resize(n, 6) = brr
    
35.     .Columns("A:G").EntireColumn.AutoFit
    
36.     End With
    
37.     wb.SaveAs p & k & ".xlsx"
    
38.     wb.Close False
    
39. Next
    
40. Application.ScreenUpdating = True
    
41. Application.DisplayAlerts = True
    
42. End Sub
    

复制代码

yanglinzi

参与一下。。

ykcbf1100

拆分成多工作簿。2级字典。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.7
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & "\分表"
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     Set sh = ThisWorkbook.Sheets("出库单明细导入")
   
8.     arr = sh.UsedRange
   
9.     bt = 1
   
10.     For i = bt + 1 To UBound(arr)
    
11.         s = arr(i, 4) & "-" & arr(i, 5) & "-" & arr(i, 6)
    
12.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
13.         d(s)(i) = Application.Index(arr, i)
    
14.     Next
    
15.     For Each k In d.keys
    
16.         sh.Copy
    
17.         Set wb = ActiveWorkbook
    
18.         m = d(k).Count
    
19.         With wb.Sheets(1)
    
20.             .Name = k
    
21.             .DrawingObjects.Delete
    
22.             .UsedRange.Offset(bt + m).Clear
    
23.             .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
24.             .Columns("d:f").Delete
    
25.         End With
    
26.         wb.SaveAs p & k
    
27.         wb.Close 1
    
28.     Next
    
29.     Sheets("操作台").Activate
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码

灵犀之声

yanglinzi 发表于 2024-5-7 18:40
参与一下。。

谢谢老师，今天没花花啦，明天给您补上

沈默00

灵犀之声 发表于 2024-5-7 18:20
老师，您的没有代码

我没有写代码，是用函数写的三个表，，
这种拆分是VBA的经典操作，，用VBA比较好