求助 大神写个简单的VBA

sljvalen

求助 大神
VBA耗材计划用量按日期和编码自动录入

3190496160

Sub 匹配()
Dim ar As Variant
Dim sh As Worksheet, sht As Worksheet
Dim d As Object, dc As Object
Dim arr()
Dim ws
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
ReDim arr(1 To Sheets.Count)
With Sheets("包材计划")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 2 Then MsgBox "包材计划为空！": End
    ar = .Range("a1:l" & r)
End With
With Sheets("sheet2")
    rs = .Cells(Rows.Count, 5).End(xlUp).Row
    If rs < 2 Then MsgBox "sheet2为空！": End
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 8), .Cells(rs, y)) = Empty
    br = .Range(.Cells(1, 1), .Cells(rs, y))
    For i = 2 To UBound(br)
        If Trim(br(i, 5)) <> "" Then
            d(Trim(br(i, 5))) = i
        End If
    Next i
    For j = 8 To UBound(br, 2)
        If Trim(br(1, j)) <> "" Then
            d(Trim(br(1, j))) = j
        End If
    Next j
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) <> "" And Trim(ar(i, 9)) <> "" Then
            xh = d(Trim(ar(i, 9)))
            lh = d(Trim(ar(i, 2)))
            If xh <> "" And lh <> "" Then
                br(xh, lh) = ar(i, 12)
            End If
        End If
    Next i
     .Range(.Cells(1, 1), .Cells(rs, y)) = br
End With
MsgBox "ok!"
End Sub

3190496160

包材.rar (18.56 KB, 下载次数: 7)

2021-12-24 16:40 上传

点击文件名下载附件

sljvalen

3190496160 发表于 2021-12-24 16:40

谢谢