使用代码创建超级表，并插入切片器

许均豪

请求大家帮助，谢谢！！！
把所有工作表从第二行开始创建超级表，并且超级表名与工作表名称一致；
然后每个工作表内插入切片器 范围为整个超级表，按钮列数调整为3，每个表主题可能不同
如 工作表：柱，插入切片器  主题为  混凝土强度等级
     工作表：楼地面，主题为 名称

fzxba

1. Sub 宏1() '录制宏，然后修改，再多了也不懂
   
2.   Dim ar, i As Integer, wks As Worksheet, Ran As Range, t As String
   
3.   For Each wks In Worksheets
   
4.     With wks
   
5.       t = .Range(Array("G2", "F2", "B2")(i)).Value
   
6.       With .Range("A1").CurrentRegion
   
7.         Set Ran = Intersect(.Offset(0), .Offset(1))
   
8.       End With
   
9.       .ListObjects.Add(1, Ran, , 1).Name = .Name
   
10.       ThisWorkbook.SlicerCaches.Add(.ListObjects(.Name), t).Slicers.Add wks, , t, t, 50, 800, 200, 200
    
11.       ThisWorkbook.SlicerCaches("切片器_" & t).Slicers(t).NumberOfColumns = 3
    
12.     End With
    
13.     i = i + 1
    
14.   Next
    
15.   Set Ran = Nothing
    
16. End Sub

复制代码

许均豪

fzxba 发表于 2024-2-4 11:33

我每次工作表的排序可能不同，所以应用的"G2", "F2", "B2")(i)位置不确定
能不能调整为 柱工作表  主题 混凝土强度等级
                    楼地面工作表 主题 名称
                    现浇板工作表 主题 材质
这种格式。
还有  ThisWorkbook.SlicerCaches.Add(.ListObjects(.Name), t).Slicers.Add wks, , t, t, 50, 800, 200, 200 这个范围可以调整为整个超级表范围吗，不用固定值，每个表的范围也不同ThisWorkbook.SlicerCaches.Add(.ListObjects(.Name), t).Slicers.Add wks, , t, t, 50, 800, 200, 200hisWorkbook.SlicerCaches.Add(.ListObjects(.Name), t).Slicers.Add wks, , t, t, 50, 800, 200, 200

fzxba

许均豪 发表于 2024-2-4 14:05
我每次工作表的排序可能不同，所以应用的"G2", "F2", "B2")(i)位置不确定
能不能调整为 柱工作表  主题  ...

测试.rar (1.01 MB, 下载次数: 9)

2024-2-4 14:34 上传

点击文件名下载附件

许均豪

fzxba 发表于 2024-2-4 14:34

回复的附件运行没有问题，删除表格也没问题，但是我新增了一张 工作表 构造柱（此表格为柱工作表复制修改工作表名称），运行显示错误
Sub 宏1()
  Dim ar, i As Integer, wks As Worksheet, Ran As Range, t As String
  Dim dict As Object
  Set dict = CreateObject("Scripting.Dictionary")
  ar = Array("柱 混凝土强度等级", "楼地面 名称", "现浇板 材质", "构造柱 混凝土强度等级")
  For i = LBound(ar) To UBound(ar)
    dict.Add Split(ar(i))(0), Split(ar(i))(1)
  Next
  For Each wks In Worksheets
    With wks
'      t = .Range(Array("G2", "F2", "B2")(i)).Value
      t = dict(.Name)
      With .Range("A1").CurrentRegion
        Set Ran = Intersect(.Offset(0), .Offset(1))
      End With
      .ListObjects.Add(1, Ran, , 1).Name = .Name
      ThisWorkbook.SlicerCaches.Add(.ListObjects(.Name), t).Slicers.Add wks, , t, t, 50, 800, 200, 200
'运行时错误'-2147418113(8000ffEf):  方法'Add’作用于对象'slicerCaches’时失败
      ThisWorkbook.SlicerCaches("切片器_" & t).Slicers(t).NumberOfColumns = 3
    End With
'    i = i + 1
  Next
  Set Ran = Nothing
  Set dict = Nothing
End Sub

fzxba

许均豪 发表于 2024-2-5 11:12
回复的附件运行没有问题，删除表格也没问题，但是我新增了一张 工作表 构造柱（此表格为柱工作表复制修改 ...

哎，我根本就不会，也就是录制宏然后改改，这得靠你自己摸索了。期待在这方面有经验的老师参与……