判断后拆分表格

Vincycc

根据第E列和第N列作为条件拆分表格，如果第E列首字母为T，则再根据第N列收货单位拆分不同工作表（“模板” — 表头不太一样，不需要把数据源全部复制），分别命名为A（铁）和B（铁）；如果第E列首字母为X或L或M或S，则分别命名为A（铝）和B（铝）；剩余其他字母划分为一类，根据收货单位分别命名为A（五金）和B（五金），详见附件。
自己研究了一下，但也只会从网上已有的看得懂的部分改改，本人不会写，暂时没看到特别相似的案例，所以还是希望借大家帮帮忙

ykcbf1100

看完有点蒙。A和B如何区分 没搞清楚。

半百

请测试。。。

Vincycc

ykcbf1100 发表于 2023-4-12 15:57
看完有点蒙。A和B如何区分 没搞清楚。

A和B就是厂家名字，我直接用字母代替了。就是数据源那个表格里面的数据根据两个条件拆分表格，一个条件是产品编码的首字母，另一个就是厂家，比如数据源那个表格里满足产品编码首字母为T（T代表铁），厂家为A，则拆一个表出来，表名为A（铁）。我觉得难在拆出来的表的表头和数据源那个表格不一样，不是直接把数据源里面的数据全部复制，有一些列不需要

Vincycc

半百 发表于 2023-4-12 16:55
请测试。。。

果然术业有专攻，大神速度就是快谢谢

Vincycc

半百 发表于 2023-4-12 16:55
请测试。。。

大神，想再请你帮帮忙，请问在拆出来的表中有一些列我需要加计算公式，比如金额那一列，金额（O)=数量(L)*单价(F)，怎么加呢？

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, 5).End(xlUp).Row
   
8.         arr = .Range("a4:s" & r)
   
9.     End With
   
10.     For i = 1 To UBound(arr)
    
11.         Select Case Left(arr(i, 5), 1)
    
12.             Case "T"
    
13.                 lx = "铁"
    
14.             Case "X", "L", "M", "S"
    
15.                 lx = "铝"
    
16.             Case Else
    
17.                 lx = "五金"
    
18.         End Select
    
19.         xm = arr(i, 14) & "（" & lx & "）"
    
20.         If Not d.exists(xm) Then
    
21.             m = 1
    
22.             ReDim brr(1 To 16, 1 To m)
    
23.         Else
    
24.             brr = d(xm)
    
25.             m = UBound(brr, 2) + 1
    
26.             ReDim Preserve brr(1 To 16, 1 To m)
    
27.         End If
    
28.         For j = 5 To 9
    
29.             brr(j - 4, m) = arr(i, j)
    
30.         Next
    
31.         brr(7, m) = arr(i, 3)
    
32.         brr(8, m) = arr(i, 19)
    
33.         brr(9, m) = arr(i, 16)
    
34.         brr(11, m) = arr(i, 14)
    
35.         brr(12, m) = arr(i, 10)
    
36.         d(xm) = brr
    
37.     Next
    
38.     For Each aa In d.keys
    
39.         brr = d(aa)
    
40.         ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
41.         For i = 1 To UBound(brr)
    
42.             For j = 1 To UBound(brr, 2)
    
43.                 crr(j, i) = brr(i, j)
    
44.             Next
    
45.         Next
    
46.         For i = 1 To UBound(crr)
    
47.             crr(i, 15) = crr(i, 6) * crr(i, 12)
    
48.         Next
    
49.         On Error Resume Next
    
50.         Worksheets(aa).Delete
    
51.         On Error GoTo 0
    
52.         Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
53.         With ws
    
54.             .Name = aa
    
55.             .Range("a3:p3") = Array("产品编码", "产品名称", "规格", "效果", "单位", "单价", "订单号码", "送货日期", "送货单号", "再编号", "收货单位", "数量", "折为对", "公斤(KG)", "金额", "备注")
    
56.             .Range("a4").Resize(UBound(crr), UBound(crr, 2)).Value = crr
    
57.             With .Range("a3").Resize(1 + UBound(crr), UBound(crr, 2))
    
58.                 .Borders.LineStyle = xlContinuous
    
59.                 With .Font
    
60.                     .Name = "微软雅黑"
    
61.                     .Size = 10
    
62.                 End With
    
63.             End With
    
64.         End With
    
65.     Next
    
66.         
    
67. '    With .UsedRange
    
68. '        .HorizontalAlignment = xlCenter
    
69. '        .VerticalAlignment = xlCenter
    
70. '    End With
    
71. End Sub
    

复制代码

chxw68

参与一下。