恳请大神们帮忙看下这个查询不同表格数据的难题

qiongmei6

我希望在附件“个税”工作表中求得一个代码，就是“个税”表格的h列 在“工资汇总”表格中的v列和“退休表格”内的z列都找不到数据，那么个税表格中对应的g：i列的数据显示在w：y中，目前的个税表格w：y列就是我希望代码执行后最后的结果，谢谢各位大神的帮忙

gwjkkkkk

Option Explicit
Sub TEST5()
    Dim ar, i&, j&, r&, dic As Object
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Worksheets("退休").[A4].CurrentRegion.Value
    For i = 3 To UBound(ar)
        dic(ar(i, 26)) = Empty
    Next i
   
    ar = Worksheets("工资汇总").[A1].CurrentRegion.Value
    For i = 3 To UBound(ar)
        dic(ar(i, 22)) = Empty
    Next i
   
    With Worksheets("个税")
        ar = .[G2].CurrentRegion.Value
        For i = 2 To UBound(ar)
            If Not dic.exists(ar(i, 2)) Then
                r = r + 1
                For j = 1 To UBound(ar, 2)
                    ar(r, j) = ar(i, j)
                Next j
            End If
        Next i
        .[W1].CurrentRegion.ClearContents
        If r Then .[W1].Resize(r, UBound(ar, 2)) = ar
    End With
   
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.7.24
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     fn = Array("退休", "工资汇总")
   
5.     For Each sht In Sheets(fn)
   
6.         With sht
   
7.             Set Rng = .UsedRange.Find("身份证号")
   
8.             c = Rng.Column
   
9.             r1 = Rng.Row
   
10.             r = .Cells(Rows.Count, c).End(3).Row
    
11.             For i = r1 + 1 To r
    
12.                 s = .Cells(i, c).Value
    
13.                 d(s) = ""
    
14.             Next
    
15.         End With
    
16.     Next
    
17.     ReDim brr(1 To 10000, 1 To 3)
    
18.     With Sheets("个税")
    
19.         Set Rng = .UsedRange.Find("身份证号")
    
20.         c = Rng.Column
    
21.         r1 = Rng.Row
    
22.         r = .Cells(Rows.Count, c).End(3).Row
    
23.         For i = r1 + 1 To r
    
24.             s = .Cells(i, c).Value
    
25.             If Not d.exists(s) Then
    
26.                 m = m + 1
    
27.                 n = 0
    
28.                 For j = c - 1 To c + 1
    
29.                     n = n + 1
    
30.                     brr(m, n) = .Cells(i, j)
    
31.                 Next
    
32.             End If
    
33.         Next
    
34.         .[w1:z1000] = ""
    
35.         .Columns("x:x").NumberFormatLocal = "@"
    
36.         .[w1].Resize(m, 3) = brr
    
37.     End With
    
38.     Set d = Nothing
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "OK！"
    
41. End Sub
    

复制代码

Qs18

Sub qs()
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
arr = Sheet8.Range("z6:z" & Sheet8.Cells(Rows.Count, "z").End(3).Row)
arr2 = Sheet13.Range("v3:v" & Sheet13.Cells(Rows.Count, "v").End(3).Row)
For i = 1 To UBound(arr)
    s = CStr(arr(i, 1))
    dic(s) = ""
Next
For i = 1 To UBound(arr2)
    ss = CStr(arr2(i, 1))
    dic(ss) = ""
Next
a = Sheet6.Range("g3:i" & Sheet6.Cells(Rows.Count, "h").End(3).Row)
ReDim brr(1 To UBound(a), 1 To 3)
For i = 1 To UBound(a)
    If Not dic.exists(CStr(a(i, 2))) Then
        m = m + 1
        For j = 1 To 3
        brr(m, j) = a(i, j)
        Next
    End If
Next
Sheet6.Range("w1").Resize(m, 3) = brr
End Sub

Qs18

试一下...........

Qs18

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

lsc900707

这格式有点怪怪的：