按多列的值汇总对应工作表内容并将结果按列新建表

anline1739

各位大神：在实际应用中遇到下面的问题：1.想要按每列粘贴的内容查找到对应的工作表；2.按每列的结果新建对应的工作表，新建表名为每列列标,即A列查找的结果新建工作表A，B列查找的结果新建工作表B；3.每个新建工作表只需要留一个表头。找的代码只能实现1与3，即只能将A列的查找结果显示在汇总表里，无法实现2的需求。另外，明细表里只是举例到D列，实际应用中会存在40多列的都有值的可能，所以麻烦考虑后续的延伸问题。望各位有经验的多多指教。万分感谢！

ykcbf1100

如果查找的结果有多个，那新建的表名不是有相同的了？

anline1739

ykcbf1100 发表于 2022-12-20 16:31
如果查找的结果有多个，那新建的表名不是有相同的了？

查找列的内容会先校验是否重复的，所以一定是不重复的，而新建的表是按列标来建，不以查找的内容来建的。

3190496160

Sub 合并工作表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
    d(sh.Name) = ""
Next sh
With Sheets("明细")
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    For j = 1 To y
        m = 0
        r = .Cells(Rows.Count, j).End(xlUp).Row
        For i = 1 To r
            If Trim(.Cells(i, j)) <> "" Then
                mc = Trim(.Cells(i, j))
                If d.exists(mc) Then
                    m = m + 1
                    If m = 1 Then
                        If Not d.exists(j & "工作表") Then
                            Sheets(mc).Copy after:=Sheets(Sheets.Count)
                            Set sht = ActiveSheet
                            sht.Name = j & "工作表"
                        Else
                            Set sht = Sheets(j & "工作表")
                            With sht
                                .UsedRange.Clear
                                Sheets(mc).Cells.Copy .[a1]
                            End With
                        End If
                    Else
                        With Sheets(mc)
                            rs = .Cells(Rows.Count, 2).End(xlUp).Row
                            If rs >= 5 Then
                                ws = sht.Cells(Rows.Count, 2).End(xlUp).Row + 1
                                .Rows("5:" & rs).Copy sht.Cells(ws, 1)
                            End If
                         End With
                    End If
                End If
            End If
        Next i
    Next j
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

按每列的值查找对应表并汇总每列新建表.rar (52.21 KB, 下载次数: 9)

2022-12-20 17:17 上传

点击文件名下载附件

fzxba

1. Sub test1()
   
2.   Dim ar, i As Integer, j As Integer, k As Integer
   
3.   Dim strName As String, Sht As Worksheet
   
4.   Application.ScreenUpdating = False
   
5.   On Error Resume Next
   
6.   ar = Worksheets("明细").Range("A1").CurrentRegion
   
7.   For j = 1 To UBound(ar, 2)
   
8.     k = 0
   
9.     strName = Split(Cells(1, j).Address, "$")(1)
   
10.     Set Sht = Worksheets(strName)
    
11.     If Err.Number <> 0 Then
    
12.       Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = strName
    
13.       Set Sht = ActiveSheet
    
14.       Err.Clear
    
15.     End If
    
16.     Sht.Cells.Delete
    
17.     For i = 1 To UBound(ar)
    
18.       If Len(ar(i, j)) Then
    
19.         k = k + 1
    
20.         If k = 1 Then
    
21.           Worksheets(ar(i, j)).Range("A1").CurrentRegion.Copy Sht.Range("A1")
    
22.         Else
    
23.           With Worksheets(ar(i, j)).Range("A1").CurrentRegion
    
24.             Intersect(.Offset(0), .Offset(4)).Copy Sht.Range("A65536").End(3)(2)
    
25.           End With
    
26.         End If
    
27.       End If
    
28.     Next
    
29.   Next
    
30.   Worksheets("明细").Activate
    
31.   Application.ScreenUpdating = True
    
32. End Sub

复制代码

anline1739

3190496160 发表于 2022-12-20 17:16
Sub 合并工作表()
Application.ScreenUpdating = False
Dim ar As Variant

非常感谢！代码的结果正是我想要的！

anline1739

fzxba 发表于 2022-12-20 17:40

非常感谢你的代码！

fzxba

anline1739 发表于 2022-12-21 08:28
非常感谢你的代码！

s  n  o  b   !