有一组数据需要根据A列单元格数据包含的英文前缀统计并分表。

咱村

VBA需求，请高手帮忙：
1、根据 sheet1 A列数据前缀统计包含sheet2中 A2-A9单元格英文字母前缀的数量（TP和YTP这种属于独立的两个前缀）  并填入C2-C9单元格；
2、筛选出sheet1 A列数据中所有含有TP 所有TMP1 所有YTP 所有YTMP1的数据，包含表头，独立存为 A表.xlsx。
3、选出sheet1 A列数据中所有含有Mp 所有TMP2 所有YMP 所有YTMP2的数据，包含表头，独立存为 B表.xlsx。


附件
数据统计和分表.rar (14.01 KB, 下载次数: 10)

2023-2-7 00:07 上传

点击文件名下载附件

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets(1).UsedRange
    For j = 2 To UBound(arr)
        If InStr(arr(j, 1), "-") > 0 Then
            str1 = Mid(Split(arr(j, 1), "-")(0), 2)
            d(str1) = d(str1) + 1
        End If
    Next j
    arr = Sheets(2).UsedRange
    For j = 2 To UBound(arr)
        arr(j, 3) = d(arr(j, 1))
    Next j
    Sheets(2).[a1].Resize(UBound(arr), 3) = arr
End Sub

liulang0808

附件内容供参考。。。。。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     With Worksheets("sheet2")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         .Range("c2:e" & r).ClearContents
   
10.         brr = .Range("a2:e" & r)
    
11.         For i = 1 To UBound(brr)
    
12.             d(brr(i, 1)) = i
    
13.         Next
    
14.     End With
    
15.     With Worksheets("sheet1")
    
16.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
17.         arr = .Range("a2:p" & r)
    
18.         For i = 1 To UBound(arr)
    
19.             xm = Mid(Left(arr(i, 1), InStr(arr(i, 1), "-") - 1), 2)
    
20.             If d.exists(xm) Then
    
21.                 m = d(xm)
    
22.                 brr(m, 3) = brr(m, 3) + 1
    
23.             End If
    
24.             If i > 1 Then
    
25.                 If xm = "TP" Or xm = "TMP1" Or xm = "YTP" Or xm = "YTMP1" Then
    
26.                     xm1 = "A"
    
27.                 Else
    
28.                     xm1 = "B"
    
29.                 End If
    
30.                 If Not d1.exists(xm1) Then
    
31.                     Set d1(xm1) = .Range("a1:p1")
    
32.                 End If
    
33.                 Set d1(xm1) = Union(d1(xm1), .Cells(i, 1).Resize(1, 16))
    
34.             End If
    
35.                
    
36.         Next
    
37.         
    
38.     End With
    
39.     With Worksheets("sheet2")
    
40.         .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
41.         For i = 1 To UBound(brr)
    
42.             If .Cells(i + 1, 4).MergeArea.Cells(1, 1).Address = .Cells(i + 1, 4).Address Then
    
43.                 .Cells(i + 1, 4).FormulaR1C1 = "=SUM(R" & i + 1 & "C3:R" & i + .Cells(i + 1, 4).MergeArea.Rows.Count & "C3)"
    
44.             End If
    
45.         Next
    
46.     End With
    
47.     Application.SheetsInNewWorkbook = 1
    
48.     For Each aa In d1.keys
    
49.         Set wb = Workbooks.Add
    
50.         With wb
    
51.             With .Worksheets(1)
    
52.                 d1(aa).Copy .Range("a1")
    
53.             End With
    
54.             .SaveAs Filename:=ThisWorkbook.Path & "" & aa
    
55.             .Close False
    
56.         End With
    
57.     Next
    
58. End Sub
    

复制代码

chxw68

统计和拆分都写了。

咱村

chxw68 发表于 2023-2-7 09:33
统计和拆分都写了。

还望大哥帮看看，筛出来的的A表和B表数据不是按照编码规则出的，每个表都存在不应该出现的数据
另外A表没有根据TP、TMP1、YTP、YTMP1的顺序排序
B表也没有MP、TMP2、YMP、YTMP2这个前缀顺序排序
还望大哥帮忙修改下

咱村

liulang0808 发表于 2023-2-7 07:57
附件内容供参考。。。。。

这个统计方法学习了 很好用

chxw68

详见附件。

咱村

chxw68 发表于 2023-2-7 12:57
详见附件。

完美解决 这套代码我需要好好研究学习下，字典，数组还是需要好好下功夫学习学习，来excelhome从小白变大牛，十分感谢大哥的帮助。

gwjkkkkk

参与一下。。。