分类复制数据到指定的表格尾

lzw5251 · 发表于 2024-12-18 08:15

本帖最后由 lzw5251 于 2024-12-18 09:16 编辑

请高手们帮助，在表格做好分类，把分类的内容用VBA代码分别复制到指定的表格后面

Qs18 · 发表于 2024-12-18 09:25

Sub qs()
Dim rng As Range
With Sheet1
r = Sheet1.Cells(Rows.Count, 3).End(3).Row
For i = 3 To r
If .Range("j" & i).Value = "代" Then
Sheet5.Range("b" & Sheet5.Cells(Rows.Count, 2).End(3).Row + 1).Resize(1, 7).Value = .Range("b" & i).Resize(1, 7).Value
End If
If .Range("j" & i).Value = "调" Then
Sheet8.Range("b" & Sheet8.Cells(Rows.Count, 2).End(3).Row + 1).Resize(1, 7).Value = .Range("b" & i).Resize(1, 7).Value
End If
Next
End With
MsgBox "完成！"
End Sub

复制代码

chxw68 · 发表于 2024-12-18 09:25

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("1")
r = .Columns(1).Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
If r > 2 Then
arr = .Range("a3:m" & r)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 10)) Then
Set d(arr(i, 10)) = .Cells(2 + i, 1).Resize(1, 8)
Else
Set d(arr(i, 10)) = Union(d(arr(i, 10)), .Cells(2 + i, 1).Resize(1, 8))
End If
Next
End If
End With
For Each aa In d.keys
With Worksheets(aa & "课登记表")
r = .Columns(1).Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
d(aa).Copy .Cells(r + 1, 1)
End With
Next
End Sub

复制代码

chxw68 · 发表于 2024-12-18 09:26

详见附件。

Qs18 · 发表于 2024-12-18 09:26

试试.........

Qs18 · 发表于 2024-12-18 09:27

试试........

蓝桥玄霜 · 发表于 2024-12-18 09:39

代课的例子：

lzw5251 · 发表于 2024-12-18 10:25

Qs18 发表于 2024-12-18 09:25

非常完美！非常感谢！

lzw5251 · 发表于 2024-12-18 10:26

蓝桥玄霜发表于 2024-12-18 09:39
代课的例子：

非常完美！非常感谢！

lzw5251 · 发表于 2024-12-18 10:27

Qs18 发表于 2024-12-18 09:27
试试........

非常完美！非常感谢！

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

[求助] 分类复制数据到指定的表格尾