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

my3022 · 发表于 2024-3-27 12:23

本帖最后由 my3022 于 2024-3-27 12:25 编辑

由于工作需要统计九类特殊群体学生，并要求分类打印装档，如果手动筛选粘贴到相应的表中太费时费力，而且如果总表中有数据变化（如有增加或减少，或学生信息发生变化），相应表又要重新复制过去，太麻烦不方便，所以请各位大佬帮搞下自动把各种类型的学生提取到相应表中。
也就是说，我只需要把总表的数据录入好，后面的9张分表就会自动提取生成该类型的学生信息，以后有变化也只需要更新总表，9张分表中涉及的数据也会同步更新。

如

shiruiqiang · 发表于 2024-3-27 13:35

大哥，你模拟数据的时候，至少身份证不要同一个号码吧

沈默00 · 发表于 2024-3-27 13:46

沈默00 · 发表于 2024-3-27 13:48

直接新建表格，后期有其他类型也会自动增加的，试一下

ykcbf1100 · 发表于 2024-3-27 14:35

总表拆分

附件供参考。。。

ykcbf1100 · 发表于 2024-3-27 14:35

参与一下。。。

Sub ykcbf() '//2024.3.27
Dim arr, brr, d
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set ws = ThisWorkbook
Set sh = ws.Sheets("总表")
arr = sh.UsedRange
For Each sht In Sheets
If sht.Name <> sh.Name Then
sht.Delete
End If
Next
For i = 4 To UBound(arr)
s = Trim(arr(i, 8))
If Not d.Exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
d(s)(i) = i
Next i
On Error Resume Next
For Each k In d.keys
sh.Copy after:=Sheets(Sheets.Count)
Set sht = Sheets(Sheets.Count)
m = 0
ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2))
With sht
.Name = k
.UsedRange.Offset(3 + d(k).Count).Clear
.DrawingObjects.Delete
For Each kk In d(k).keys
m = m + 1
brr(m, 1) = m
For j = 2 To UBound(arr, 2)
brr(m, j) = arr(kk, j)
Next
Next
.Columns(4).NumberFormatLocal = "@"
.[a4].Resize(m, UBound(arr, 2)) = brr
End With
Next k
sh.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "共用时：" & Format(Timer - tm) & "秒！"
End Sub

复制代码

fzxba · 发表于 2024-3-27 14:40

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
For Each wks In Worksheets
If wks.Name <> "总表" Then wks.Delete
Next
ReDim rowsHeight(1 To titleRow + 1)
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets(1)
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(1).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

复制代码

fzxba · 发表于 2024-3-27 14:49

' 以下4法，均是平时练习，未设格式
Sub test1() '数组快排
Dim data, wks As Worksheet
Dim i As Long, j As Long, rowSize As Long
Dim titleRow As Long, splitCol As Long
titleRow = 3 '标题所在行
splitCol = 8 '拆分依据列
DoApp False
Worksheets("总表").Activate
For Each wks In Worksheets
If wks.Name <> ActiveSheet.Name Then wks.Delete
Next
With Range("A1").CurrentRegion
data = .Resize(.Rows.Count + 1).Value
End With
QuickSort data, titleRow + 1, UBound(data) - 1, 1, UBound(data, 2), splitCol
rowSize = titleRow
For i = titleRow + 1 To UBound(data) - 1
rowSize = rowSize + 1
For j = 1 To UBound(data, 2)
data(rowSize, j) = data(i, j)
Next
If data(i, splitCol) <> data(i + 1, splitCol) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = data(i, splitCol)
With ActiveSheet
.Range("A1").Resize(rowSize, j - 1) = data
.Columns.AutoFit
End With
rowSize = titleRow
End If
Next
Worksheets(1).Activate
DoApp
Beep
End Sub
Sub test2() 'ADO + SQL
Dim Conn As Object, rs As Object
Dim strConn As String, SQL As String, str_ As String
Dim wks As Worksheet, data, titleRow As Long, splitCol As Long
titleRow = 3 '标题所在行
splitCol = 8 '拆分依据列
DoApp False
Worksheets("总表").Activate
For Each wks In Worksheets
If wks.Name <> ActiveSheet.Name Then wks.Delete
Next
Set Conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
If Application.Version < 12 Then
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
End If
Conn.Open strConn & ThisWorkbook.FullName
With Range("A1").CurrentRegion
data = .Resize(titleRow).Value
str_ = .Parent.Name & "$" & Intersect(.Offset(0), .Offset(titleRow - 1)).Address(0, 0)
End With
SQL = "SELECT DISTINCT [" & data(titleRow, splitCol) & "] FROM [" & str_ & "]"
rs.Open SQL, Conn, 1, 3
SQL = "SELECT * FROM [" & str_ & "] WHERE TRIM([" & data(titleRow, splitCol) & "])='[str_]'"
While Not rs.EOF
str_ = rs.Fields(0).Value
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = str_
With ActiveSheet
.Range("A1").Resize(titleRow, UBound(data, 2)) = data
.Range("A" & titleRow + 1).CopyFromRecordset Conn.Execute(Replace(SQL, "[str_]", str_))
.Columns.AutoFit
End With
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
Conn.Close
Set Conn = Nothing
Worksheets(1).Activate
DoApp
Beep
End Sub
Sub test3() ' 字典
Dim dict As Object, wks As Worksheet
Dim data, i As Long, j As Long, strKey As String
Dim titleRow As Long, splitCol As Long
titleRow = 3 '标题所在行
splitCol = 8 '拆分依据列
DoApp False
Worksheets("总表").Activate
For Each wks In Worksheets
If wks.Name <> ActiveSheet.Name Then wks.Delete
Next
Set dict = CreateObject("Scripting.DictionAry")
With Range("A1").CurrentRegion
j = .Columns.Count
data = .Columns(splitCol)
End With
For i = titleRow + 1 To UBound(data)
strKey = data(i, 1)
If Len(strKey) Then
If Not dict.Exists(strKey) Then Set dict(strKey) = Range("A1").Resize(titleRow, j)
Set dict(strKey) = Union(dict(strKey), Range("A" & i).Resize(1, j))
End If
Next
For i = 0 To dict.Count - 1
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = dict.Keys()(i)
dict.Items()(i).Copy .Range("A1")
.Columns.AutoFit
End With
Next
Worksheets(1).Activate
Set dict = Nothing
DoApp
Beep
End Sub
Sub test4() '字典定位数组嵌套测试过30W+数据，速度最快
Dim data, temp() As String, results(), dict As Object, wks As Worksheet
Dim i As Long, j As Long, posRow As Long
Dim titleRow As Long, splitCol As Long
titleRow = 3 '标题所在行
splitCol = 8 '拆分依据列
DoApp False
Worksheets("总表").Activate
For Each wks In Worksheets
If wks.Name <> ActiveSheet.Name Then wks.Delete
Next
Set dict = CreateObject("Scripting.Dictionary")
data = Range("A1").CurrentRegion
ReDim temp(1 To UBound(data), 1 To UBound(data, 2))
For j = 1 To UBound(data, 2)
For i = 1 To titleRow
temp(i, j) = data(i, j)
Next
Next
For i = titleRow + 1 To UBound(data)
If Not dict.Exists(data(i, splitCol)) Then dict(data(i, splitCol)) = dict.Count + 1
Next
ReDim results(1 To dict.Count, 1 To 2)
For i = 1 To dict.Count
results(i, 1) = titleRow
results(i, 2) = temp
Next
For i = titleRow + 1 To UBound(data)
posRow = dict(data(i, splitCol))
results(posRow, 1) = results(posRow, 1) + 1
For j = 1 To UBound(data, 2)
results(posRow, 2)(results(posRow, 1), j) = data(i, j)
Next
Next
For i = 1 To dict.Count
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = results(i, 2)(titleRow + 1, splitCol)
.Range("A1").Resize(results(i, 1), UBound(data, 2)) = results(i, 2)
.Columns.AutoFit
End With
Next
Worksheets(1).Activate
Set dict = Nothing
DoApp
Beep
End Sub
Function QuickSort(ar, u As Long, d As Long, l As Long, r As Long, pos As Long)
Dim t As Long, b As Long, x As Long, y As Long, pivot As String, swap
t = u
b = d
pivot = ar((u + d) \ 2, pos)
While t <= b
Do
If StrComp(ar(t, pos), pivot, vbTextCompare) = -1 Then t = t + 1 Else Exit Do
Loop While t < d
Do
If StrComp(pivot, ar(b, pos), vbTextCompare) = -1 Then b = b - 1 Else Exit Do
Loop While b > u
If t < b Then
For x = l To r
swap = ar(t, x): ar(t, x) = ar(b, x): ar(b, x) = swap
Next
t = t + 1: b = b - 1
Else
If t = b Then t = t + 1: b = b - 1
End If
Wend
If u < b Then QuickSort ar, u, b, l, r, pos
If t < d Then QuickSort ar, t, d, l, r, pos
End Function
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
End Function

复制代码

fzxba · 发表于 2024-3-27 14:52

灌一灌.zip (49.24 KB, 下载次数: 20)

my3022 · 发表于 2024-3-27 14:54

本帖最后由 my3022 于 2024-3-27 15:02 编辑

谢谢三位大佬了，是不是总表有数据变化都只能重新拆分，不能同步更新

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分