单元格变化一分二提取双表模块求助

icenotcool

各位老师好，我有个工作簿，我模拟了“部门资产盘点表”表，位置是固定的，根据“部门资产盘点表”表C2单元格变化（使用部门）同时从“资产数据库”提取到两个不同表“部门资产盘点表”和“更正底稿”，按“资产名称”排序提炼出来，先谢谢各位老师，已经上传附件。

lss001

请到原帖下载附件

3190496160

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$2" Then
    Dim arr As Variant, i
    Dim brr(), crr()
    arr = Sheet3.Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    ReDim crr(1 To UBound(arr), 1 To 17)
    s = Sheet1.[c2].Value
    For i = 2 To UBound(arr)
        If arr(i, 10) = s Then
            m = m + 1
            For c = 2 To UBound(arr, 2)
                brr(m, c) = arr(i, c)
            Next
            brr(m, 1) = m
            crr(m, 1) = m
            crr(m, 2) = arr(i, 2)
            crr(m, 3) = arr(i, 3)
            crr(m, 5) = arr(i, 4)
            crr(m, 10) = arr(i, 10)
            crr(m, 11) = arr(i, 11)
            For j = 5 To 9
                crr(m, j + 8) = arr(i, j)
            Next j
        End If
    Next
    If m = "" Then MsgBox "没有所选部门的数据！": End
    r = Cells(Rows.Count, 1).End(xlUp).Row
    If r > 3 Then Range("a4:m" & r).Borders.LineStyle = 0: Range("a4:m" & r) = Empty
    Range("a4").Resize(m, UBound(brr, 2)) = brr
    Range("a4").Resize(m, UBound(brr, 2) + 2).Borders.LineStyle = 1
    With Sheets("更正底稿")
        rs = .Cells(Rows.Count, 1).End(xlUp).Row
        If r > 1 Then .Range("a2:r" & r).Borders.LineStyle = 0: .Range("a2:r" & r) = Empty
        .Range("a2").Resize(m, UBound(crr, 2)) = crr
        .Range("a2").Resize(m, UBound(crr, 2) + 1).Borders.LineStyle = 1
    End With
End If
End Sub

3190496160

示例20241006新.rar (61.96 KB, 下载次数: 8)

2024-10-7 09:41 上传

点击文件名下载附件

3190496160

只要在部门资产盘点表的C2单元格选择部门，同时生成两个表的数据，表格给你做了一些美化处理，供参考

icenotcool

3190496160 发表于 2024-10-7 09:43
只要在部门资产盘点表的C2单元格选择部门，同时生成两个表的数据，表格给你做了一些美化处理，供参考

3190496160老师，这就正是我想要的效果，真的非常谢谢你的帮助！