跨工作簿录查改删数据

SCWYZJ

求助:我想制作一个在不打开不影响源数据的情况下，可实现录入、查询、修改、删除的效果，但代码我实在不会写。虽然网上有老师的写过些，但不够全面完整，很多是不跨工作簿的。所以，特来此请求大神老师帮助写个完整的的跨工作簿的代码(详见附件)。谢谢!

shiruiqiang

不打开不影响源数据的情况下，可实现录入、查询、修改、删除?
修改、删除哪个数据表的内容？

SCWYZJ

shiruiqiang 发表于 2024-5-2 22:20
不打开不影响源数据的情况下，可实现录入、查询、修改、删除?
修改、删除哪个数据表的内容？

对，可以录入新数据到指定工作簿中的表1，也可多条件查询数据，修改数据，删除数据。修政和删除是在当前工作表的b8开始显示的查询结果中去修改或删除，修改或删除的同时一并修改或删除指定工作簿中的表1中对应的数据。

乐铁松

SCWYZJ 发表于 2024-5-3 00:36
对，可以录入新数据到指定工作簿中的表1，也可多条件查询数据，修改数据，删除数据。修政和删除是在当前 ...

这样，就与“不影响源数据”的初衷相悖了。

ykcbf1100

可实现录入、查询、修改、删除？
建议你使用数据库更方便。

3190496160

Sub 新增()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Workbook
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "数据.xls*")
If f = "" Then MsgBox "找不到数据源文件！": End
With ActiveSheet
    ar = .Range("b5:n5")
    sl = Application.CountBlank(.Range("B5:M5"))
    If sl > 0 Then MsgBox "请把数据录入完整！": End
End With
Set wb = Workbooks.Open(lj & f, 0)
With wb.Worksheets(1)
    r = .Cells(Rows.Count, 2).End(xlUp).Row + 1
    .Cells(r, 2).Resize(1, UBound(ar, 2)) = ar
End With
wb.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

Sub chaxun()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant, cr As Variant
Dim wb As Workbook
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "数据.xls*")
If f = "" Then MsgBox "找不到数据源文件！": End
With ActiveSheet
    ar = .Range("b5:n5")
    ReDim br(1 To UBound(ar, 2), 1 To 2)
    For j = 1 To UBound(ar, 2)
        If ar(1, j) <> "" Then
            n = n + 1
            br(n, 1) = ar(1, j)
            br(n, 2) = j
        End If
    Next j
    If n = "" Then MsgBox "至少输入一个查询条件！": End

    Set wb = Workbooks.Open(lj & f, 0)
    With wb.Worksheets(1)
        r = .Cells(Rows.Count, 2).End(xlUp).Row
        cr = .Range("b4:n" & r)
    End With
    wb.Close False
    ReDim arr(1 To UBound(cr), 1 To UBound(cr, 2))
    For i = 2 To UBound(cr)
        sl = 0
        For s = 1 To n
            lh = br(s, 2)
            If cr(i, lh) = br(s, 1) Then
                sl = sl + 1
            End If
        Next s
        If sl = n Then
            m = m + 1
            For j = 1 To UBound(cr, 2)
                arr(m, j) = cr(i, j)
            Next j
        End If
    Next i
    If m = "" Then MsgBox "没有符合条件的数据！": End
    .UsedRange.Offset(7) = Empty
    .[b8].Resize(m, UBound(arr, 2)) = arr
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

跨工作簿登查改删数据.rar (28.75 KB, 下载次数: 27)

2024-5-3 09:54 上传

点击文件名下载附件

3190496160

只写了新增，查询两段代码，供参考