不打开目标工作薄传递新数据至另一工作薄

转角处的沉思

请教如下：有两个工作薄分别在不同的文件夹，当每次打开或者关闭（打卡或关闭哪种方式触发合理取其为触发条件）数据表工作薄时触发新数据工作表内数据于查询表工作薄中查询工作表内部分数据进行去重比较（注比较的过程为不用打开查询表工作薄）,如标题3列对应的数据有新增则将新增的标题3列行数据连同标题5这2列对应的行数据自动补充到查询表内保存。（简单实例如截图所示）

quqiyuan

工作簿关闭事件，供参考。。。

quqiyuan

代码如下。。。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim sht As Worksheet
    Set sht = ThisWorkbook.Sheets(1)
    arr = sht.UsedRange
    crr = sht.UsedRange.Rows(1)
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sht.Parent.Path & "\"
        .AllowMultiSelect = False
        .Title = "选择查询表所在的文件夹："
        If .Show Then p = .SelectedItems(1) Else Exit Sub
    End With
    p = p & "\"
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    With Workbooks.Open(p & "查询表.xlsx").Sheets(1)
        brr = .UsedRange
        For j = 1 To UBound(brr, 2)
            n = Application.Match(brr(1, j), crr, 0)
            For i = 2 To UBound(brr)
                d(brr(i, j)) = ""
            Next
            For k = 2 To UBound(arr)
                If Not d.exists(arr(k, n)) Then
                    r = .Cells(Rows.Count, j).End(3).Row + 1
                    .Cells(r, j) = arr(k, n)
                End If
            Next
            d.RemoveAll
        Next
        .Parent.Close 1
    End With
    Set d = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

转角处的沉思

quqiyuan 发表于 2024-7-2 23:15
代码如下。。。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim sht As Worksheet

感谢帮助，完满运行，不过如果将关闭工作簿后选择查询表这一手选模式定义为某指定路径文件夹需如何修改呢。

quqiyuan

转角处的沉思 发表于 2024-7-3 07:58
感谢帮助，完满运行，不过如果将关闭工作簿后选择查询表这一手选模式定义为某指定路径文件夹需如何修改呢 ...

转角处的沉思

quqiyuan 发表于 2024-7-3 08:04

感谢答疑，明白了，这样更便捷。

转角处的沉思

quqiyuan 发表于 2024-7-3 08:04

你好，再次请教下，我测试了下数据，发现这个程序好像是同时判断标题3和标题5这2列是否有重复后补充数据了，实际需求是只需判断标题3这一列是否有重复，把新增不重复的补充到查询表内（补充的同时只需把标题5列所在的行数据一起带过来，不用额外判断标题5列是否有重复的），这个需要如何调整呢，感谢。

quqiyuan

改了下，供参考。。。标题不管几个，都可以处理，不管你说的只有两个的情况，多用了个字典

quqiyuan

代码如下。。。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim sht As Worksheet
    Set sht = ThisWorkbook.Sheets(1)
    arr = sht.UsedRange
    crr = sht.UsedRange.Rows(1)
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sht.Parent.Path & "\"
        .AllowMultiSelect = False
        .Title = "选择查询表所在的文件夹："
        If .Show Then p = .SelectedItems(1) Else Exit Sub
    End With
    p = p & "\"
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    With Workbooks.Open(p & "查询表.xlsx").Sheets(1)
        brr = .UsedRange
        For j = 1 To UBound(brr, 2)
            n = Application.Match(brr(1, j), crr, 0)
            If IsNumeric(n) Then dic(n) = ""
        Next
        Key = dic.keys
        n = Key(0)
        For i = 2 To UBound(brr)
            d(brr(i, 1)) = ""
        Next
        For k = 2 To UBound(arr)
            If Not d.exists(arr(k, n)) Then
                r = .Cells(Rows.Count, 1).End(3).Row + 1
                For j = 0 To UBound(Key)
                .Cells(r, j + 1) = arr(k, Key(j))
                Next
            End If
        Next
        d.RemoveAll
'        Next
        .Parent.Close 1
    End With
    Set d = Nothing
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

转角处的沉思

quqiyuan 发表于 2024-7-4 15:16
改了下，供参考。。。标题不管几个，都可以处理，不管你说的只有两个的情况，多用了个字典

感谢帮助，灵活性提高了很多.