条件匹配取数

sulgz

求助.zip (46.04 KB, 下载次数: 9)

2024-1-1 09:16 上传

点击文件名下载附件

蓝桥玄霜

科目的例子：

3190496160

Sub 匹配()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("核算项目表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    If r < 3 Or y < 3 Then MsgBox "核算项目表为空！": End
    ar = .Range(.Cells(2, 1), .Cells(r, y))
End With
For j = 3 To y Step 2
    If Trim(ar(1, j)) <> "" Then
        For i = 2 To UBound(ar)
            If Trim(ar(i, j - 1)) <> "" Then
                zd = Trim(ar(1, j)) & "|" & Trim(ar(i, j - 1))
                d(zd) = ar(i, j)
            End If
        Next i
    End If
Next j
With Sheets("科目汇总表")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 7 Then MsgBox "科目汇总表为空！": End
    .Range("d7:e" & rs) = Empty
    br = .Range(.Cells(5, 1), .Cells(rs, 11))
    For i = 3 To UBound(br)
        If Trim(br(i, 1)) <> "" And Trim(br(i, 2)) <> "" Then
            zd = Trim(br(i, 1)) & "|" & Trim(br(i, 2))
            If d.exists(zd) Then
                If Trim(br(i, 11)) = "借" Then
                    br(i, 4) = d(zd)
                Else
                    br(i, 5) = d(zd)
                End If
            End If
        End If
    Next i
    .[d5].Resize(UBound(br), 1) = Application.Index(br, 0, 4)
    .[e5].Resize(UBound(br), 1) = Application.Index(br, 0, 5)
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

求助.rar (59.7 KB, 下载次数: 18)

2024-1-1 09:56 上传

点击文件名下载附件

sulgz

3190496160 发表于 2024-1-1 09:56

可以增加一个功能，如果B列没有C员工，但核算项目表里有，那么将核算项目表里有B列没有的C员工数据在最后数据行里增加?

3190496160

在论坛混了十多年了，也看了楼主之前的好多帖子，没有一次送花，没有一次中肯的评价，更没有一句对别人的付出表示感谢的话
不要把别人对自己的付出看成是理所当然

sulgz

3190496160 发表于 2024-1-2 16:56
在论坛混了十多年了，也看了楼主之前的好多帖子，没有一次送花，没有一次中肯的评价，更没有一句对别人的付 ...

不知道有送花功能，评价有那是你没看到，代码很好用，但不代表能随便恶意中伤别人