将同类人员明细表复制到另一表中

FXZ2015

各位老师，需要将“人员名册”表中，按类别1至类别5中各个类型的人员分类复制到“成表”中。

即：将类别1至类别5中所有“残疾”人员的信息复制到“成表”中，隔一行或两行，复制“半失能”人员，以此类推，将所有有内容的分类复制到“成表”中。
请老师帮忙。
名册2.rar (121.05 KB, 下载次数: 15)

2024-8-22 09:35 上传

点击文件名下载附件

limonet

关键字：distinct

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, Brr As Variant, j%
    Brr = Sheet4.Range("A3:K3")
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Arr = Cn.Execute("Select Distinct 类别1 From [人员名册$A3:K] Where 类别1<>''").GetRows
    For i = 0 To UBound(Arr, 2)
        j = Range("B" & Rows.Count).End(xlUp).Row + 2
        StrSQL = "Select * From [人员名册$A3:K] Where 类别1='" & Arr(0, i) & "'"
        Range("A" & j).Resize(1, 11) = Brr
        Range("A" & j + 1).CopyFromRecordset Cn.Execute(StrSQL)
    Next i
    Rows("1:2").Delete
End Sub

蓝桥玄霜

名册的例子：

FXZ2015

蓝桥玄霜 发表于 2024-8-22 10:25
名册的例子：

老师，我看了一下，类别1里的项的明细都复制过来了。
但有几项在类别2或类别3里的，明细复制的不全。
如，大病，总计5个人，只复制了在类别1里的3个人，类别2和类别3里各1人没有复制；
低保，总计1人，在类别2列里，没有复制；
失能，总计7人，只复制了3人。
老师，您看怎么改一下，给老师添麻烦了。

FXZ2015

limonet 发表于 2024-8-22 10:21
Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, Brr As Variant, j%
    Brr = Shee ...

老师，不知道什么原因，统计的不全。
如，半失能4人，只复制了3人；失能7人，只复制了3人。等。
麻烦老师，看怎么改一下。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.22
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("人员名册")
   
5.         r = .Cells(Rows.Count, 5).End(3).Row
   
6.         arr = .[a1].Resize(r, 11)
   
7.         Set Rng = .[a3].Resize(, 11)
   
8.     End With
   
9.     For i = 5 To UBound(arr)
   
10.         s = arr(i, 6)
    
11.         If s <> Empty Then
    
12.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
13.             d(s)(i) = i
    
14.         End If
    
15.     Next
    
16.     With Sheets("成表")
    
17.         .UsedRange.ClearContents
    
18.         .Columns(3).NumberFormatLocal = "@"
    
19.         For Each k In d.keys
    
20.             m = m + 1
    
21.             Rng.Copy .Cells(m, 1)
    
22.             For Each kk In d(k).keys
    
23.                 m = m + 1
    
24.                 For j = 1 To UBound(arr, 2)
    
25.                     .Cells(m, j) = arr(kk, j)
    
26.                 Next
    
27.             Next
    
28.             m = m + 1
    
29.         Next
    
30.     End With
    
31.     Set d = Nothing
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    

复制代码

FXZ2015

ykcbf1100 发表于 2024-8-22 12:21
附件供参考。。。

老师，还是没复制全。
比如，失能人员4个，复制了3个。
麻烦老师，怎么改一下。

ykcbf1100

FXZ2015 发表于 2024-8-22 12:41
老师，还是没复制全。
比如，失能人员4个，复制了3个。
麻烦老师，怎么改一下。

哪来的4个？难道你的数据和我们不一样？
代码没有问题，爱用不用。