[已解决]筛选数据并分别复制粘贴到新建的工作表中，帮忙写下VBA代码，谢谢！

baojun026

根据E列“子编号”筛选数据并分别复制粘贴到后面的自动新建的工作表中（第6行开始粘贴），工作表以筛选的子编号命名，另外H列“分类”以Z-A重新扩展排序。（示例文件的后面5个工作表为执行后的效果）

帮忙写下VBA代码，非常感谢！

清单示例.zip (33.14 KB, 下载次数: 15)

2022-4-11 15:00 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

lisachen

2022-4-11 16:23

1. 
   

复制代码

1. Sub test()
   
2. 
   
3.    
   
4.    
   
5.     Dim arr, brr, resultArr(1 To 1000, 1 To 26)
   
6.     Dim dic As Object
   
7.     Dim x%, y%, k%
   
8.     Set dic = CreateObject("scripting.dictionary")
   
9.     arr = Sheets("export").Range("a1").CurrentRegion
   
10.     brr = Sheets("export").Range("a1:w1")
    
11.     For x = 2 To UBound(arr)
    
12.         If Not dic.exists(arr(x, 5)) Then
    
13.             dic(arr(x, 5)) = 1
    
14.         End If
    
15.     Next x
    
16.     For Each Item In dic
    
17.         For x = 2 To UBound(arr)
    
18.             If arr(x, 5) = Item Then
    
19.                 k = k + 1
    
20.                 For y = 1 To UBound(arr, 2)
    
21.                     resultArr(k, y) = arr(x, y)
    
22.                 Next y
    
23.             End If
    
24.         Next x
    
25.         With Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
    
26.             .Name = Item
    
27.             .Range("a6").Resize(1, 23) = brr
    
28.             .Range("a7").Resize(k, 23) = resultArr
    
29.         End With
    
30.         k = 0
    
31.         Erase resultArr
    
32.     Next
    
33. End Sub

复制代码

跳转到最佳答案楼层

lisachen

1. 
   

复制代码

1. Sub test()
   
2. 
   
3.    
   
4.    
   
5.     Dim arr, brr, resultArr(1 To 1000, 1 To 26)
   
6.     Dim dic As Object
   
7.     Dim x%, y%, k%
   
8.     Set dic = CreateObject("scripting.dictionary")
   
9.     arr = Sheets("export").Range("a1").CurrentRegion
   
10.     brr = Sheets("export").Range("a1:w1")
    
11.     For x = 2 To UBound(arr)
    
12.         If Not dic.exists(arr(x, 5)) Then
    
13.             dic(arr(x, 5)) = 1
    
14.         End If
    
15.     Next x
    
16.     For Each Item In dic
    
17.         For x = 2 To UBound(arr)
    
18.             If arr(x, 5) = Item Then
    
19.                 k = k + 1
    
20.                 For y = 1 To UBound(arr, 2)
    
21.                     resultArr(k, y) = arr(x, y)
    
22.                 Next y
    
23.             End If
    
24.         Next x
    
25.         With Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
    
26.             .Name = Item
    
27.             .Range("a6").Resize(1, 23) = brr
    
28.             .Range("a7").Resize(k, 23) = resultArr
    
29.         End With
    
30.         k = 0
    
31.         Erase resultArr
    
32.     Next
    
33. End Sub

复制代码

lisachen

清单示例.rar (45.48 KB, 下载次数: 4)

2022-4-11 16:52 上传

点击文件名下载附件

1. Sub test()
   
2.     Dim arr, brr, resultArr(1 To 1000, 1 To 26)
   
3.     Dim dic As Object
   
4.     Dim x%, y%, k%
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     arr = Sheets("export").Range("a1").CurrentRegion
   
7.     brr = Sheets("export").Range("a1:w1")
   
8.     For x = 2 To UBound(arr)
   
9.         If Not dic.exists(arr(x, 5)) Then
   
10.             dic(arr(x, 5)) = 1
    
11.         End If
    
12.     Next x
    
13.     For Each Item In dic
    
14.         For x = 2 To UBound(arr)
    
15.             If arr(x, 5) = Item Then
    
16.                 k = k + 1
    
17.                 For y = 1 To UBound(arr, 2)
    
18.                     resultArr(k, y) = arr(x, y)
    
19.                 Next y
    
20.             End If
    
21.         Next x
    
22.         For x = 1 To UBound(resultArr) - 1
    
23.         For y = x + 1 To UBound(resultArr)
    
24.             If resultArr(x, 8) < resultArr(y, 8) Then
    
25.                 For j = 1 To 23
    
26.                 temp = resultArr(x, j)
    
27.                 resultArr(x, j) = resultArr(y, j)
    
28.                 resultArr(y, j) = temp
    
29.                 Next j
    
30.             End If
    
31.         Next y
    
32.     Next x
    
33.         With Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
    
34.             .Name = Item
    
35.             .Range("a6").Resize(1, 23) = brr
    
36.             .Range("a7").Resize(k, 23) = resultArr
    
37.         End With
    
38.         k = 0
    
39.         Erase resultArr
    
40.     Next
    
41. End Sub

复制代码

baojun026

baojun026

lisachen 发表于 2022-4-11 16:33

师傅，我有个地方漏描述了，有点搞不懂帮忙再补充一下，非常感谢！
筛选过去的每个新表增加B1=B7，B2=C7，B3=E7，B4=F8，B5=V7。代码要怎么修改？帮忙看看，谢谢了！

釜底抽薪

我用文件筛选功能写了个 只是排序问题还解决
Sub chafei()
    Dim sht As Worksheet
    Dim d As Object
    Dim i As Integer, ar As Variant
    Set d = CreateObject("scripting.dictionary")
    With Worksheets("export")
        If .AutoFilterMode = True Then Selection.AutoFilter
        ar = .Range("e2:e" & .Cells(Rows.Count, 5).End(xlUp).Row)
    End With
    For i = 1 To UBound(ar)
        On Error Resume Next
        d.Add ar(i, 1), ""
    Next i
    With Worksheets("export")
    For i = 1 To d.Count
        myn = Application.Index(d.Keys, 0, i)
        myn = myn(UBound(myn))
        .Rows("1:1").AutoFilter field:=5, Criteria1:=myn
        .AutoFilter.Range.SpecialCells(12).Copy
        Set sht = Worksheets.Add(, Worksheets(Worksheets.Count))
        sht.Name = myn
        sht.Range("a6").PasteSpecial
        .Select
        Selection.AutoFilter
    Next i
    End With
End Sub

lisachen

baojun026 发表于 2022-4-11 17:17
师傅，我有个地方漏描述了，有点搞不懂帮忙再补充一下，非常感谢！
筛选过去的每个新表增加B1=B7，B2=C7 ...

1. Sub test()
   
2.     Dim arr, brr, resultArr(1 To 1000, 1 To 26)
   
3.     Dim dic As Object
   
4.     Dim x%, y%, k%
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     arr = Sheets("export").Range("a1").CurrentRegion
   
7.     brr = Sheets("export").Range("a1:w1")
   
8.     For x = 2 To UBound(arr)
   
9.         If Not dic.exists(arr(x, 5)) Then
   
10.             dic(arr(x, 5)) = 1
    
11.         End If
    
12.     Next x
    
13.     For Each Item In dic
    
14.         For x = 2 To UBound(arr)
    
15.             If arr(x, 5) = Item Then
    
16.                 k = k + 1
    
17.                 For y = 1 To UBound(arr, 2)
    
18.                     resultArr(k, y) = arr(x, y)
    
19.                 Next y
    
20.             End If
    
21.         Next x
    
22.         For x = 1 To UBound(resultArr) - 1
    
23.         For y = x + 1 To UBound(resultArr)
    
24.             If resultArr(x, 8) < resultArr(y, 8) Then
    
25.                 For j = 1 To 23
    
26.                 temp = resultArr(x, j)
    
27.                 resultArr(x, j) = resultArr(y, j)
    
28.                 resultArr(y, j) = temp
    
29.                 Next j
    
30.             End If
    
31.         Next y
    
32.     Next x
    
33.         With Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
    
34.             .Name = Item
    
35.             .Range("a6").Resize(1, 23) = brr
    
36.             .Range("a7").Resize(k, 23) = resultArr
    
37.             .[B1] = .[B7]
    
38.             .[B2] = .[C7]
    
39.             .[B3] = .[E7]
    
40.             .[B4] = .[F7]
    
41.             .[B5] = .[V7]
    
42.         End With
    
43.         k = 0
    
44.         Erase resultArr
    
45.     Next
    
46. End Sub

复制代码

            .[B1] = .[B7]
            .[B2] = .[C7]
            .[B3] = .[E7]
            .[B4] = .[F7]
            .[B5] = .[V7]

baojun026

lisachen 发表于 2022-4-11 17:31
. = .
            . = .[C7]
            . = .[E7]

OK，非常感谢！