求助老师根据需求分发数据到工作簿

cdg168pro

求助老师，根据需求分发数据到工作簿

祝：老师工作顺利、家庭幸福、万事如意！！！

ykcbf1100

按耗材及服务商表中耗材名拆分，格式同样本表。已测试通过。
不过，目前，总表中没有服务商，故拆分后的工作簿中没有服务商数据。

ykcbf1100

代码如下：

1. Sub ykcbf()   '//2023.2.14
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr, brr(1 To 1000, 1 To 10), d
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Dim tm: tm = Timer
   
7.     With Sheets("耗材及服务商")
   
8.         r = .Cells(Rows.Count, 1).End(xlUp).Row
   
9.         arr = .[a1].Resize(r, 1)
   
10.     End With
    
11.     For i = 2 To UBound(arr)
    
12.         s = Trim(arr(i, 1))
    
13.         If s <> "" Then
    
14.             d(s) = s
    
15.         End If
    
16.     Next i
    
17.     With Sheets("汇总数据")
    
18.         r = .Cells(Rows.Count, 2).End(xlUp).Row
    
19.         c = .Cells.Find("*", SearchOrder:=xlByColumns, searchdirection:=xlPrevious).Column
    
20.         arr = .[a1].Resize(r, c)
    
21.     End With
    
22.     For Each k In d.keys
    
23.         m = 0
    
24.         For i = 2 To UBound(arr)
    
25.             For j = 6 To UBound(arr, 2)
    
26.                 s = Trim(arr(i, j))
    
27.                 If s <> Empty Then
    
28.                     If s = k Then
    
29.                         m = m + 1
    
30.                         brr(m, 1) = m
    
31.                         brr(m, 2) = arr(i, 2)
    
32.                         brr(m, 4) = arr(i, 3)
    
33.                         brr(m, 5) = arr(i, 4)
    
34.                         brr(m, 10) = arr(i, 5)
    
35.                     End If
    
36.                 End If
    
37.             Next
    
38.         Next
    
39.         If m > 0 Then
    
40.             Sheets("样本").Copy
    
41.             Set wb = ActiveWorkbook
    
42.             Set sht = wb.Worksheets(1)
    
43.             With sht
    
44.                 .Name = k
    
45.                 .[a4] = "工作簿名称《" & k & "》"
    
46.                 .[a7].Resize(m, UBound(brr, 2)) = brr
    
47.                 .[a7].Resize(m, UBound(brr, 2)).Columns.AutoFit
    
48.             End With
    
49.             wb.SaveAs Filename:=ThisWorkbook.Path & "" & k & ".xlsx"
    
50.             wb.Close
    
51.         End If
    
52.     Next
    
53.     Application.ScreenUpdating = True
    
54.     Application.DisplayAlerts = True
    
55.     MsgBox "拆分完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
56. End Sub
    

复制代码

wxxydl

给你写了一个

半百

删除前三个表外的所有分表，重新生成工作表。

cdg168pro

ykcbf1100 发表于 2023-2-14 13:32
按耗材及服务商表中耗材名拆分，格式同样本表。已测试通过。
不过，目前，总表中没有服务商，故拆分后的工 ...

谢谢老师

cdg168pro

wxxydl 发表于 2023-2-14 13:43
给你写了一个

谢谢老师

cdg168pro

半百 发表于 2023-2-14 13:58
删除前三个表外的所有分表，重新生成工作表。

谢谢老师

cdg168pro

半百 发表于 2023-2-14 13:58
删除前三个表外的所有分表，重新生成工作表。

老师你好，还有个需求求助下你

cdg168pro

半百 发表于 2023-2-14 13:58
删除前三个表外的所有分表，重新生成工作表。

老师