根据sheet1数据自动生成N个表2

3190496160

Sub 新建工作表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("单元号")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "单元号工作表为空，请先导入数据！": End
    ar = .Range("a1:b" & r)
End With
For Each sh In Sheets
    If sh.Index > 2 Then
        d(sh.Name) = ""
    End If
Next sh
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" And ar(i, 2) <> "" Then
        s = ar(i, 1) & "|" & ar(i, 2)
        If Not d.exists(s) Then
            Sheets("模板").Copy after:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = s
                .[z4] = ar(i, 1)
                .[f7] = ar(i, 2)
            End With
        End If
    End If
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

Private Sub Worksheet_SelectionChange(ByVal T As Range)
If T.Row > 1 And T.Column = 2 Then
    If T.Count > 1 Then End
    If T.Offset(, -1) = "" Or T.Value = "" Then End
    s = T.Offset(, -1) & "|" & T.Value
    Sheets(s).Activate
End If
End Sub

3190496160

001-C5-1 【保护层】隐蔽工程检查验收记录 - 副本 - 副本.rar (123.27 KB, 下载次数: 7)

2024-11-26 09:43 上传

点击文件名下载附件

3190496160

在单元格工作表的B列单击可以进入相应的工作表

袁勇

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, k&, i&, sh As Worksheet
   
3.     arr = Sheets("单元号").[a1].CurrentRegion
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.    
   
8.     For Each sh In ThisWorkbook.Worksheets
   
9.         If sh.Name <> "单元号" And sh.Name <> "模板" Then
   
10.             sh.Delete
    
11.         End If
    
12.     Next
    
13.     ActiveWorkbook.Save
    
14.     Application.DisplayAlerts = True
    
15. 
    
16.     For i = 2 To UBound(arr)
    
17.         k = Worksheets.Count
    
18.         Sheets("模板").Copy after:=Sheets(k)
    
19.         ActiveSheet.Name = arr(i, 1)
    
20.         With ActiveSheet
    
21.             .[z4] = arr(i, 1)
    
22.             .[f7] = arr(i, 2)
    
23.         End With
    
24.     Next
    
25.     Application.ScreenUpdating = True
    
26.     Sheets("单元号").Activate
    
27. End Sub

复制代码

袁勇

生成工作表（sheet)

乐彩007

袁勇 发表于 2024-11-26 09:46

谢谢大神，小弟

乐彩007

3190496160 发表于 2024-11-26 09:42
Sub 新建工作表()
Application.ScreenUpdating = False
Dim ar As Variant

十分感谢，大佬的眷顾，谢谢，祝你天天好心情。

乐彩007

3190496160 发表于 2024-11-26 09:42
Sub 新建工作表()
Application.ScreenUpdating = False
Dim ar As Variant

感谢大神的帮助，让我顺利地完成了任务，顺便在老婆面前大显伸手。当表格自动生成的那一刻，她看我的眼神又回到了初恋时那般热烈，我感觉我又行了

乐彩007

3190496160 发表于 2024-11-26 09:42
Private Sub Worksheet_SelectionChange(ByVal T As Range)
If T.Row > 1 And T.Column = 2 Then
    If  ...

感谢大神慷慨相助，我的问题解决了，我并不从事与表格相关工作，只是7年前遇到了这样的问题，在这个论坛里得到了好心人的帮助。感恩大神。谢谢你