vba如何使用工作表事件匹配人员信息？

lwz2019

1.我想在给工作表sheet1复制信息时，能自动从”人员信息“提取对应信息，从站里找了个例子，但还是不对，代码在工作表的sheet1里！
2.把”实验数据“（或从任意表里）的信息，粘贴到sheet1中，能自动根据表头从”人员信息“中匹配出对应信息，如果没有，对应信息为空，不会被删除，详情见附件！先谢了！

mmwwdd

liulang0808

Private Sub Worksheet_Change(ByVal Target As Range)
    Set d = CreateObject("scripting.dictionary")
    Set Rng = Application.Intersect(Columns(3), Target)
    If Rng Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    arr = Sheets("人员信息").UsedRange
    For j = 2 To UBound(arr)
        d(arr(j, 3)) = j
    Next j
    For j = 2 To UBound(arr, 2)
        d(arr(1, j)) = j
    Next j
    For Each rn In Rng
        If Len(rn) = 0 Then
            Cells(rn.Row, 4).Resize(1, 3).Value = ""
            Cells(rn.Row, 2) = ""
            Cells(rn.Row, 1) = ""
        Else
            
            If Not d.exists(rn.Value) Then
                Cells(rn.Row, 4).Resize(1, 5).Value = ""
                Cells(rn.Row, 1) = ""
            Else
                r = d(rn.Value)
                Cells(rn.Row, 1) = WorksheetFunction.CountA([a1].Resize(rn.Row - 1)) - 1
                For i = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
                    Cells(rn.Row, i) = "'" & arr(r, d(Cells(1, i).Value))
                Next i
            End If
        End If
    Next
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

liulang0808

供参考。。。。。。。。。。。。

sxbjzjf110

参与一下。。。。

lwz2019

mmwwdd 发表于 2023-3-28 06:22

不知道什么原因，用你的代码，提取不到数据？

lwz2019

mmwwdd 发表于 2023-3-28 06:22

知道问题在我这，1看成i了，谢谢帮助！