根据已知单位名称汇总提取指定数据

APPLE123

根据已知单位名称汇总提取指定数据



1、各单位每年上报一个工作簿，每个工作簿有若干工作表，每个工作表格式基本一样。
2、本表B列属于已知数据，有的单位有上报，有的单位没有上报。
3、现因工作需要，需核对本表B列所列的单位是否有上报，
      （1）如有上报，则在本表H列相应单元格填写“已报”，
                 并从这个上报工作簿中提取相应数据到本表，模拟结果详见本表
                 B列至G列数据从相应工作表提取，详见各列的说明
        （2）如未上报，则在本表H列相应单元格填写“未找到”。

请老师帮帮忙，想用vba一键核对是否上报并提取相应数据，谢谢！

shiruiqiang

yynrzwh

根据已知单位名称汇总提取指定数据.zip (92.53 KB, 下载次数: 10)

2024-6-17 21:35 上传

点击文件名下载附件

APPLE123

shiruiqiang 发表于 2024-6-17 21:03

谢谢老师的帮助！测试结果正确

APPLE123

yynrzwh 发表于 2024-6-17 21:35

谢谢老师的帮助！真是好方法。

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    ReDim brr(1 To 1, 1 To 6)
    Set fso = CreateObject("scripting.filesystemobject")
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")
    Set d = CreateObject("scripting.dictionary")
    r = ws.Cells(Rows.Count, 1).End(3).Row
    arr = ws.[a3].Resize(r - 2, 8)
    For i = 1 To UBound(arr)
        d(arr(i, 2)) = i
    Next
    p = ThisWorkbook.Path & "\"
    wb_name = fso.getbasename(wb.Name)
    For Each f In fso.getfolder(p).Files
        If InStr(f.Name, wb_name) = 0 Then
            If LCase(f.Name) Like "*.xls*" Then
                n = 1
                With Workbooks.Open(f, 0)
                    s = .Sheets("基本信息").[c5]
                    If d.exists(s) Then
                    brr(n, 1) = .Sheets("基本信息").[c7]
                    brr(n, 2) = .Sheets("基本信息").[c14]
                    brr(n, 3) = .Sheets("同一品牌").[c3]
                    brr(n, 4) = .Sheets("服务资本市场").[c4]
                    brr(n, 5) = .Sheets("服务高质量发展").[c4]
                    brr(n, 6) = "已报"
                    .Close 0
                    ws.Cells(d(s) + 2, 3).Resize(, 6) = brr
                    End If
                End With
            End If
        End If
    Next
    With ws
        For i = 1 To UBound(arr)
            If .Cells(i + 2, 8) <> "已报" Then .Cells(i + 2, 8) = "未找到"
        Next
    End With
    Beep
    Application.ScreenUpdating = True
    Set fso = Nothing
    Set d = Nothing
End Sub