跨表格姓名配对，自动匹配性别难题

合作

要求表2、表3、表4等 提取与表1姓名相匹配的性别，自动填充在标黄处。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.22
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     With Sheets("Sheet1")
   
7.         r = .Cells(Rows.Count, 2).End(3).Row
   
8.         arr = .Range("b6:c" & r)
   
9.     End With
   
10.     For i = 1 To UBound(arr)
    
11.         s = arr(i, 1)
    
12.         d(s) = arr(i, 2)
    
13.     Next
    
14.     p = ThisWorkbook.Path & ""
    
15.     On Error Resume Next
    
16.     For Each f In Fso.GetFolder(p).Files
    
17.         If f.Name Like "*.xlsx" Then
    
18.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
19.                 fn = Fso.GetBaseName(f)
    
20.                 Set wb = Workbooks.Open(f, 0)
    
21.                 With wb.Sheets(1)
    
22.                     s = .[b2]
    
23.                     .[c2] = d(s)
    
24.                     wb.Close 1
    
25.                 End With
    
26.             End If
    
27.         End If
    
28.     Next f
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, strPath$, strFileName$, dic As Object
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [B7].CurrentRegion.Value
    For i = 2 To UBound(ar)
        dic(ar(i, 1)) = ar(i, 2)
    Next i
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls*")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With Workbooks.Open(strPath & strFileName)
                With .Sheets(1).[B1].CurrentRegion
                    ar = .Value
                    For i = 2 To UBound(ar)
                        ar(i, 2) = dic(ar(i, 1))
                    Next i
                    .Value = ar
                End With
                .Close True
            End With
        End If
        strFileName = Dir
    Loop
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

gwjkkkkk

请参考。。。

合作

ykcbf1100 发表于 2024-1-22 19:52
附件供参考。。。

高手，自动填充代码在那看，想修改下

ykcbf1100

合作 发表于 2024-1-22 19:57
高手，自动填充代码在那看，想修改下

代码在模块1里面