根据shee3设定的筛选字段筛选sheet1数据到新工作簿

咱村

研究了好几天，还是没有弄出来，高手请帮忙。

按照sheet3中字段，将Sheet1数据按照筛选字段的顺序导出到新工作簿：
1、新工作簿包含sheet1的标题行，按照shee3中A列出现的名字命名；
2、筛选字段为sheet1中A列数据前缀，sheet3筛选根据工作需要，由人工填入
3、根据sheet3筛选字段筛选sheet1数据，同时将sheet1中的D列填入串联后的数据（填入规则：对应sheet1的E列数据 & sheet1的B1单元格内容& 对应的筛选字段（将末尾是数字的数字部分删除） & 在新工作表中从1开始的顺序号   已经填好几个事例形如：A公司9TP1
3、按照前缀B2开始单元格出现前缀的顺序将sheet1标题行和数据导出到由A列对应的工作簿中。
需求描述如下


最终达到效果如下


附件已经更新如下
附件及演示效果.rar (337.81 KB, 下载次数: 2)

2023-2-11 17:57 上传

点击文件名下载附件

3190496160

Sub 筛选()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
With Sheets("Sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range(.Cells(1, 1), .Cells(r, 16))
    h_1 = .[b1]
End With
Set sh = ThisWorkbook.Worksheets("Sheet3")
With sh
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To rs
        n = 0
        ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
        y = .Cells(i, Columns.Count).End(xlToLeft).Column
        For j = 2 To y
            If Trim(.Cells(i, j)) <> "" Then
                zd = zd & .Cells(i, j)
                For s = 2 To UBound(ar)
                    If InStr(ar(s, 1), .Cells(i, j)) > 0 Then
                        n = n + 1
                        For jj = 1 To UBound(ar, 2)
                            br(n, jj) = ar(s, jj)
                        Next jj
                    End If
                Next s
            End If
        Next j
        If n > 0 Then
            For s = 1 To n
                If Trim(br(s, 1)) <> "" Then
                    br(s, 4) = br(s, 5) & h_1 & .Cells(i, 2) & s
                End If
            Next s
            Sheets("sheet1").Copy
            Set wb = ActiveWorkbook
            With wb.Worksheets(1)
                .Range("a2:q" & r) = Empty
                .[a2].Resize(n, UBound(br, 2)) = br
            End With
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & .Cells(i, 1) & ".xlsx"
            wb.Close
        End If
    Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

附件新.rar (23.55 KB, 下载次数: 7)

2023-2-11 09:17 上传

点击文件名下载附件

咱村

3190496160 发表于 2023-2-11 09:17

基本实现了，但是还差一个在新生成的工作簿里边，根据筛选字段的顺序排序显示，另外在sheet1中需要串联前缀字段而不是只串联TP字段，串联的时候需要把筛选字段的最后那个数字删除，再串联编号顺序。还望帮忙完善下，实在是看不懂

3190496160

咱村 发表于 2023-2-11 12:32
基本实现了，但是还差一个在新生成的工作簿里边，根据筛选字段的顺序排序显示，另外在sheet1中需要串联前 ...

果然不出所料，你自己都描述不清楚，你让别人如何帮你呢？认真看看你一楼的描述和目前的描述吧

gwjkkkkk

咱村 发表于 2023-2-11 12:32
基本实现了，但是还差一个在新生成的工作簿里边，根据筛选字段的顺序排序显示，另外在sheet1中需要串联前 ...

模拟一下结果看看。。。

咱村

gwjkkkkk 发表于 2023-2-11 14:02
模拟一下结果看看。。。

重新更新了一下附件，同时加了个演示附件，帮忙看下哈，谢谢啦。

咱村

3190496160 发表于 2023-2-11 13:33
果然不出所料，你自己都描述不清楚，你让别人如何帮你呢？认真看看你一楼的描述和目前的描述吧

怪我没描述清楚，十分感谢帮忙

gwjkkkkk

咱村 发表于 2023-2-11 18:19
重新更新了一下附件，同时加了个演示附件，帮忙看下哈，谢谢啦。

你自己检查一下模拟结果第13条，是不是搞错了，代码帮你写好了。。。