求一个VBA代码

3190496160

保留BOM全表的所有格式拆分
求VBA代码.rar (31.36 KB, 下载次数: 9)

2024-2-17 09:07 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, j&, dic As Object, Rng As Range, wks As Worksheet

    DoApp False
    Set dic = CreateObject("Scripting.Dictionary")
    With Worksheets("BOM全表").[A1].CurrentRegion
        ar = .Resize(.Rows.Count + 1)
        Set Rng = .Rows(1)
        For i = 2 To UBound(ar) - 1
            If Len(ar(i, 1)) Then
                If Not dic.exists(ar(i, 1)) Then
                    Set dic(ar(i, 1)) = Rng
                End If
                For j = i To UBound(ar) - 1
                    If j = UBound(ar) - 1 Or ar(j + 1, 1) <> 0 Then
                         Set dic(ar(i, 1)) = Union(dic(ar(i, 1)), .Rows(i & ":" & j))
                         Exit For
                    End If
                Next j
            End If
        Next
    End With
   
    ar = Worksheets("需求").[A1].CurrentRegion.Value
    With Workbooks.Add
        For i = 2 To UBound(ar)
            If dic.exists(ar(i, 1)) Then
                With .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
                    .Name = ar(i, 1)
                    dic(ar(i, 1)).Copy
                    .[A1].PasteSpecial xlPasteColumnWidths
                    dic(ar(i, 1)).Copy .[A1]
                End With
            End If
        Next
        For Each wks In .Worksheets
            If wks.Name Like "*Sheet*" Then wks.Delete
        Next
    End With
    Call CreateList
    Set dic = Nothing: Set Rng = Nothing
    DoApp
    Beep
End Sub
Function DoApp(Optional b As Boolean = True)
    With Application
        .ScreenUpdating = b
        .DisplayAlerts = b
        .Calculation = -b * 30 - 4135
    End With
End Function
        
Sub CreateList()
    Dim i&
   
    Worksheets.Add(before:=Worksheets(1)).Name = "工作表目录"
    [A1].Resize(, 2) = [{"序号", "需求BOM"}]
    For i = 2 To Worksheets.Count
        Cells(i, 1).Value = i - 1
        ActiveSheet.Hyperlinks.Add Cells(i, 2), "", Worksheets(i).Name & "!A2", _
        "单击打开：" & Worksheets(i).Name, Worksheets(i).Name
        
        Worksheets(i).Hyperlinks.Add Worksheets(i).Cells(2, 1), "", _
        Worksheets(1).Name & "!B" & i, "返回目录"
    Next i
   
    Columns("A:D").AutoFit
End Sub

gwjkkkkk

请参考。。。

hjd528

我的需求与楼主的很类似，借用楼主的帖子，向各位老师求代码。
条件表中的有一些关键词，根据这些关键词在总表中的户籍住址栏中进行查找，将所有的人员的所有信息提取到新表（每个新表的名称都以这些关键词进行命名）。代码是百度AI的，已实现需求，但总感觉到有些怪怪的。特向老师们求助。

根据条件表中的关键词查找总表中的户籍住址的人员提取信息到新表.rar (20.31 KB, 下载次数: 5)

2024-2-17 11:12 上传

点击文件名下载附件

shiruiqiang

hjd528 发表于 2024-2-17 11:20
我的需求与楼主的很类似，借用楼主的帖子，向各位老师求代码。
条件表中的有一些关键词，根据这些关键词在 ...

=================

hjd528

shiruiqiang 发表于 2024-2-17 12:18
=================

谢谢！今天没有花了，明天送上。