如何使用VBA实现从工作表中提取符合关键字的数据行并按设定格式显示在另一工作表中

3190496160

Sub 导入数据()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object
Dim cr()
Dim rn As Range
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\未入库文件\"
With Sheets("已入")
    r = .Cells(Rows.Count, 16).End(xlUp).Row
    If r < 2 Then MsgBox "请输入要导入的质检号！": End
    ar = .Range("p1:p" & r)
    For i = 2 To UBound(ar)
        If ar(i, 1) <> "" Then
            d(ar(i, 1)) = ""
        End If
    Next i
    f = Dir(lj & "进货明细.xlsx")
    If f = "" Then MsgBox "找不到进货明细工作簿文件！": End
    Set wb = Workbooks.Open(lj & f, 0)
    With wb.Worksheets("23年进货明细")
        rs = .Cells(Rows.Count, 10).End(xlUp).Row
        br = .Range("a1:l" & rs)
        ReDim cr(1 To UBound(br), 1 To UBound(br, 2))
        For i = 2 To UBound(br)
            If br(i, 10) <> "" Then
                If d.exists(br(i, 10)) Then
                    n = n + 1
                    For j = 1 To UBound(br, 2)
                        cr(n, j) = br(i, j)
                    Next j
                    If rn Is Nothing Then
                        Set rn = .Cells(i, 1).Resize(1, 12)
                    Else
                        Set rn = Union(rn, .Cells(i, 1).Resize(1, 12))
                    End If
                End If
            End If
        Next i
        If Not rn Is Nothing Then rn.Interior.ColorIndex = 4
    End With
    wb.Close True
    .[a1].CurrentRegion.Offset(1) = Empty
    If n = "" Then MsgBox "23年进货明细中没有你需要导入的数据！": End
    .[a2].Resize(n, UBound(cr, 2)) = cr
End With
det d = Nothing
Application.ScreenUpdating = True
MsgBox "导入完毕！"
End Sub

3190496160

超越2018

3190496160 发表于 2023-11-21 08:41
2.”已入“工作表的数据信息再按新格式放到”入库“工作表中。
直接一步到位不行吗，为什么要多一个步骤 ...

多一个步骤是因为中间数据还有用处，需要手动标注合同号、入库日期并留存备查

超越2018

chxw68 发表于 2023-11-21 08:48
参与一下。

代码写的很漂亮，厉害

超越2018

3190496160 发表于 2023-11-21 08:54
Sub 导入数据()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant

代码写的很细致，功能实现挺好，厉害，没有鲜花了有了就补上，谢谢