VBA大神进，如何实现把sheet名插入到表中

mark420

如图，从第二张表开始，把工作簿中的除第一张表，后面的每一个表都用表名填充到第一列，从A8开始填充表名，希望能实现除第一张的每张sheet都能实现（大概20张sheet表），谢谢各位大神

swl4561255

修改工作表名称后重新运行程序查看效果。

1. Sub test()
   
2. n = ThisWorkbook.Sheets.Count
   
3. For i = 2 To n
   
4.   ar = Sheets(i).[A65536].End(3).Row
   
5.      For j = 8 To ar
   
6.        Sheets(i).Cells(j, 1) = Sheets(i).Name
   
7.      Next
   
8. Next
   
9. End Sub

复制代码

q3698995

1. Private Sub CommandButton1_Click()
   
2.     For i = 1 To ThisWorkbook.Sheets.Count
   
3.         With Sheets(i): s = .Name
   
4.             If IsNumeric(s) Then
   
5.                 r = .Cells(.Rows.Count, 1).End(3).Row
   
6.                 If r > 8 Then
   
7.                     If .Cells(7, 1).Value2 <> "房间" Then
   
8.                         ReDim brr(1 To r, 1 To 1): brr(7, 1) = "房间": For j = 8 To r: brr(j, 1) = s: Next
   
9.                         .Columns(1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   
10.                         .Cells(1, 1).Resize(r).Value2 = brr
    
11.                     End If
    
12.                 End If
    
13.             End If
    
14.         End With
    
15.     Next
    
16.     MsgBox "完成！"
    
17. End Sub

复制代码

太极拍天雄

练习一下......

mark420

q3698995 发表于 2024-4-2 10:51

大哥点了没效果。。

mark420

太极拍天雄 发表于 2024-4-2 11:17
练习一下......

大哥厉害！
谢谢啦

q3698995

mark420 发表于 2024-4-2 13:05
大哥点了没效果。。

1. Private Sub CommandButton1_Click(): a: End Sub
   
2. Sub a()
   
3.     For i = 1 To ThisWorkbook.Sheets.Count
   
4.         With Sheets(i): s = .Name: If IsNumeric(s) Then r = .Cells(.Rows.Count, 1).End(3).Row: If r > 8 Then If .Cells(7, 1).Value2 <> "房间" Then ReDim brr(1 To r, 1 To 1): brr(7, 1) = "房间": For j = 8 To r: brr(j, 1) = s: Next: .Columns(1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove: .Cells(1, 1).Resize(r).Value2 = brr
   
5.         End With
   
6.     Next: MsgBox "完成！"
   
7. End Sub

复制代码

q3698995

mark420 发表于 2024-4-2 13:05
大哥点了没效果。。

代码肯定是有效，可能是按钮不支持，我换个按钮给你。