跨工作簿筛选提取数据VBA

kisskings

因工作所需，需要将附件内日报数据中数据按自动筛选中筛选条件进行筛选，将结果复制到自动筛选筛选数据工作表中，其中后两个筛选条件（见图）为多个，人员代码对应上料者筛选，最好能够加入所有列取消隐藏再进行复制，因为日报数据偶尔会有隐藏列，谢谢！    


筛选.rar (509.3 KB, 下载次数: 24)

2020-10-24 17:06 上传

点击文件名下载附件

microyip

论坛里大把案例可以参考，不会吟诗也会偷

大秦帝国白起

参考：
技巧51 不打开工作簿取得其他工作簿数据.rar (20.46 KB, 下载次数: 102)

2020-10-24 17:24 上传

点击文件名下载附件

kisskings

microyip 发表于 2020-10-24 17:15
论坛里大把案例可以参考，不会吟诗也会偷

难度有点大

kisskings

大秦帝国白起 发表于 2020-10-24 17:24
参考：

谢谢，筛选值太多了  单纯的拷贝还是不得行

kisskings

人工顶置一下   烦请帮忙谢谢！

kisskings

人工顶置一下   烦请帮忙谢谢！

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    r = Sheets(2).UsedRange.Rows.Count
    arr = [a2].Resize(r, 3)
    For j = 2 To UBound(arr)
        If Len(arr(j, 1)) > 0 Then d(CDate(arr(j, 1))) = j
        If Len(arr(j, 2)) > 0 Then d(arr(j, 2)) = j
        If Len(arr(j, 3)) > 0 Then d(arr(j, 3)) = j
    Next j
    arr = Sheets(3).UsedRange
    r = 0
   
    For j = 3 To UBound(arr)
        If d.exists(CDate(arr(j, 2))) And d.exists(arr(j, 4)) And d.exists(arr(j, 5)) And d.exists(arr(j, 6)) Then
            r = r + 1
            For x = 1 To UBound(arr, 2)
                arr(r, x) = arr(j, x)
            Next x
        End If
    Next j
    Sheets(1).UsedRange.Offset(1).ClearContents
    If r <> 0 Then Sheets(1).[a1].Resize(r, UBound(arr, 2)) = arr
End Sub

liulang0808

表格合并到一个文件内了，具体楼主可以根据需求调整

1016373263

Sub wwww()
Dim d As Object, sht As Worksheet, sht1 As Worksheet, sht2 As Worksheet, wb As Workbook, file As String, arr, arr1()
Set d = CreateObject("scripting.dictionary")
Set sht = Worksheets("筛选条件")
Set sht1 = Worksheets("筛选数据")
n = sht.UsedRange.Rows.Count
    arr = sht.[a2].Resize(n, 3)
    For J = 2 To UBound(arr)
        If Len(arr(J, 1)) > 0 Then d(CDate(arr(J, 1))) = J
        If Len(arr(J, 2)) > 0 Then d(arr(J, 2)) = J
        If Len(arr(J, 3)) > 0 Then d(arr(J, 3)) = J
    Next J
file = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While file <> ""
If file <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & file
Set wb = ActiveWorkbook
Set sht2 = wb.Worksheets(1)
arr = sht2.UsedRange
   For J = 3 To UBound(arr)
        If d.exists(arr(J, 2)) And d.exists(arr(J, 5)) And d.exists(arr(J, 4)) Then
            m = m + 1
            ReDim Preserve arr1(1 To m)
            arr1(m) = Application.Index(arr, J, 0)
        End If
   Next J
wb.Close
End If
file = Dir
Loop
sht1.UsedRange.Offset(1).ClearContents
If m = 0 Then Exit Sub
sht1.[a2].Resize(m, UBound(arr, 2)) = Application.Transpose(Application.Transpose(arr1))
End Sub