[求助] VBA怎样根据总表中数据按类别筛选数据到相应表中？

fzxba

Sub test0()
  
  Dim ar, dict As Object, wks As Worksheet, ran As Range
  Dim rowsHeight() As Double, strKey As String
  Dim i As Long, j As Long, titleRow As Long, splitCol As Long
  
  titleRow = 3   '标题所在 行
  splitCol = 8   '拆分依据 列
  
  DoApp False
  
  Set dict = CreateObject("Scripting.Dictionary")
  
  ar = Array("总表", "统计表", "封面")  '不必删除的 工作表  在这里列出来
  For j = 0 To UBound(ar)
    dict.Add ar(j), ""
  Next
  
  For Each wks In Worksheets
    If Not dict.Exists(wks.Name) Then wks.Delete
  Next
  
  dict.RemoveAll
  ReDim rowsHeight(1 To titleRow + 1)
  
  With Worksheets("总表")
    For j = 1 To UBound(rowsHeight)
      rowsHeight(j) = .Rows(j).RowHeight
    Next
    With .Range("A1").CurrentRegion
      ar = .Value
      Set ran = .Resize(titleRow)
    End With
    For i = titleRow + 1 To UBound(ar) '- 1
      strKey = Trim(ar(i, splitCol))
      If Len(strKey) Then
        If Not dict.Exists(strKey) Then Set dict(strKey) = ran
        Set dict(strKey) = Union(dict(strKey), .Range("A" & i).Resize(, UBound(ar, 2)))
      End If
    Next
  End With
  
  For j = 0 To dict.Count - 1
    With Worksheets.Add(After:=Worksheets(Worksheets.Count))
      ran.Copy
      .Range("A1").PasteSpecial xlPasteColumnWidths
      dict.Items()(j).Copy .Range("A1")
      For i = 1 To UBound(rowsHeight) - 1
        .Rows(i).RowHeight = rowsHeight(i)
      Next
      .Rows(i & ":" & .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row).RowHeight = rowsHeight(i)
      .Name = dict.Keys()(j)
      .DrawingObjects.Delete
    End With
  Next
  
  Worksheets("总表").Activate
  
  Set ran = Nothing
  Set dict = 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

h2016

这个例子看一下

lizhipei78

https://club.excelhome.net/thread-1681303-1-1.html

沈默00

my3022 发表于 2024-3-27 17:38
点拆分和删除都会把增加进去的统计表和封面删除掉，怎么修改代码，删除的处理了，能保留下新增的统计表和 ...

要改好几个地方，还是把你的真实表格发上来吧，
这种方式新增内容时直接按钮点一下，就全部重新生成了，数据会更新的

125675117

好心人多，感谢感谢

my3022

ykcbf1100 发表于 2024-3-27 17:01
之所以没有保留你原来的表，我这里是因为有些表数据拆分不进去，不知道是不是你的表名和总表中的类型名不 ...

谢谢大佬细心解释，如果要我在这个表中新增固定的统计表和封面，如何在点拆分时不会删除新增固定的统计表和封面，现在一点拆分就会删除掉

my3022

沈默00 发表于 2024-3-27 16:40
把你的原表发上来，数据你截取一部分就行了，不然我也不知道要保留哪些表，，，，

也会修改按学校拆分了，用你后来发的代码也能解决拆分后不会删除需要保留的表了，只是拆分时感觉没有原来的代码流畅，有卡顿，也没有原来用时短

沈默00

my3022 发表于 2024-3-28 09:38
也会修改按学校拆分了，用你后来发的代码也能解决拆分后不会删除需要保留的表了，只是拆分时感觉没有原来 ...

自己会改可以试着摸索一下，只要数据量不是太大，不至于很卡的，

ykcbf1100

my3022 发表于 2024-3-28 09:28
谢谢大佬细心解释，如果要我在这个表中新增固定的统计表和封面，如何在点拆分时不会删除新增固定的统计表 ...

上传附件。。。

my3022

1、如何在拆分时保留“统计表、总封面和分封面”

2、如果要按年级和班级拆分，怎么修改代码（也就是拆分成班级名册，原来只是按一列类别进行拆分，现在变成要按两列的类别进行拆分）
谢谢各位大佬的指点，按1列类别进行拆分已勉强会根据需要修改了