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

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, Brr As Variant, j%, Sht As Range, Crr As Variant
    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
    Crr = Application.Transpose(Application.Transpose(Sheet4.Range("F3:J3")))
    For Each Sht In Sheet4.Range("F3:J3")
        StrSQL = StrSQL & " Union All Select * From [人员名册$" & Sht.Address(0, 0) & ":" & Left(Sht.Address(0, 0), 1) & "]"
    Next Sht
    Arr = Cn.Execute("Select Distinct 类别1 From (" & Mid(StrSQL, 12) & ") 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 " & Join(Crr, "='" & Arr(0, i) & "' or ") & "='" & 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

limonet

多加循环与判断。

lsc900707

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

改下这几句：

1. For i = 4 To UBound(arr)
   
2.         For j = 6 To UBound(arr, 2) - 1
   
3.             s = arr(i, j)
   
4.             If s <> "" Then
   
5.                 If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
   
6.                 d(s)(i) = i
   
7.             End If
   
8.         Next
   
9.     Next

复制代码

FXZ2015

ykcbf1100 发表于 2024-8-22 12:44
哪来的4个？难道你的数据和我们不一样？
代码没有问题，爱用不用。

类别1到类别5，您只看了类别1，类别2和类别3里还有。

FXZ2015

limonet 发表于 2024-8-22 12:55
Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, Brr As Variant, j%, Sht As Range,  ...

谢谢老师，问题解决了

FXZ2015

limonet 发表于 2024-8-22 12:55
Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, Brr As Variant, j%, Sht As Range,  ...

老师，如果我想将分类的数据复制到指定的表中，如将分类的数据从“人员名册表”指定复制到表名为”成表“中，应该改哪段代码，请老师帮忙。

limonet

worksheets("成表").Range

FXZ2015

limonet 发表于 2024-8-22 15:13
worksheets("成表").Range

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, Brr As Variant, j%, Sht As Range, Crr As Variant
    Brr = Worksheets("人员名册").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
    Crr = Application.Transpose(Application.Transpose(Worksheets("人员名册").Range("F3:J3")))
    For Each Sht In Worksheets("人员名册").Range("F3:J3")
        Debug.Print Sht.Address(0, 0) & ":" & Left(Sht.Address(0, 0), 1)
        StrSQL = StrSQL & " Union All Select * From [人员名册$" & Sht.Address(0, 0) & ":" & Left(Sht.Address(0, 0), 1) & "]"
    Next Sht
    Arr = Cn.Execute("Select Distinct 类别1 From (" & Mid(StrSQL, 12) & ") Where 类别1<>''").GetRows
    For i = 0 To UBound(Arr, 2)
        j = Worksheets("成表").Range("B" & Rows.Count).End(xlUp).Row + 2
        StrSQL = "Select * From [人员名册$A3:K] Where " & Join(Crr, "='" & Arr(0, i) & "' or ") & "='" & Arr(0, i) & "'"
        Worksheets("成表").Range("A" & j).Resize(1, 11) = Brr
        Worksheets("成表").Range("A" & j + 1).CopyFromRecordset Cn.Execute(StrSQL)
    Next i
    Worksheets("成表").Rows("1:2").Delete
End Sub




老师，我把sheet4，也改了。这样改对吗？

FXZ2015

limonet 发表于 2024-8-22 15:13
worksheets("成表").Range

老师，在人员名册表中最左侧加了一列，改了一下代码，不行。
请老师帮忙改一下，谢谢。

名册3.rar (128.03 KB, 下载次数: 2)

2024-8-22 20:14 上传

点击文件名下载附件

ylj518

参与一下！