根据条件，从两个表中提取数据进行组合

Qs18

Sub qs()
Dim arr, i, s, dic
s = "书记、校长、专职副书记、副校长、工会主席"
Set dic = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a7:i" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
ReDim brr(1 To 10000, 1 To 14)
ar = Sheet2.Range("b6:e" & Sheet2.Cells(Rows.Count, 2).End(3).Row).Value
For i = 1 To UBound(ar)
    ss = ar(i, 1)
    dic(ss) = Array(ar(i, 2), ar(i, 3), ar(i, 4))
Next
For i = 1 To UBound(arr)
    If InStr(s, arr(i, 8)) Then
        m = m + 1
        brr(m, 1) = m
        brr(m, 2) = arr(i, 2)
        tt = dic(arr(i, 2))
        brr(m, 3) = tt(0): brr(m, 4) = tt(1): brr(m, 5) = tt(2)
        
        brr(m, 6) = VBA.Replace(arr(i, 3), "1名", "")
        brr(m, 8) = arr(i, 4)
        xx = Mid(arr(i, 5), 17, 1)
        brr(m, 9) = IIf(Val(xx) Mod 2, "男", "女")
        brr(m, 10) = VBA.DateSerial(Mid(arr(i, 5), 7, 4), Mid(arr(i, 5), 11, 2), Mid(arr(i, 5), 3, 2))
        brr(m, 11) = DateDiff("yyyy", brr(m, 10), Date)
        brr(m, 13) = arr(i, 8)
    End If
Next
Sheet3.Range("a6").Resize(1000, 14).ClearContents
Sheet3.Range("a6").Resize(m, 14) = brr
Set dic = Nothing
End Sub

Qs18

试试........

Qs18

试试...........

cqxingchen

yanglinzi 发表于 2024-9-1 22:20
请测试。。

感谢老师。

cqxingchen

ykcbf1100 发表于 2024-9-1 22:08
这样吗？

老师您好：
现在有一个新问题，提取数据到目标表后，字号都变成11号了，且改变了单元格式。
有没有一种方法，让写入数据后，不改变目标表格式呢。
比如目标格式有自动换行、缩小字体填充、字号9号、字体等。

ykcbf1100

cqxingchen 发表于 2024-9-3 13:16
老师您好：
现在有一个新问题，提取数据到目标表后，字号都变成11号了，且改变了单元格式。
有没有一种 ...

你源数据二个表，一个表字体11号，另一个字体9号，怎么保持原来的字号啊。
算了，我设置了一下，应该能满足你的要求了。你也可以根据自己要求再改一下。