提取指定工作簿下多个文件指定单元格的数据

lsc900707

代码在审核，附件供测试：

dagal

lsc900707 发表于 2018-7-30 11:18
字典能解决这个问题，但名称要求统一：
Sub gj23w98()
    Set wb = GetObject(ThisWorkbook.Path & "\"  ...

Set wb = GetObject(ThisWorkbook.Path & "\" & "1807-JZ07客房营业日报表.xls")，李老师，这是指定了文件名，能否改为选择文件呢？不然定死了每个月文件都不一样哦。。。

lsc900707

dagal 发表于 2018-7-31 19:04
Set wb = GetObject(ThisWorkbook.Path & "\" & "1807-JZ07客房营业日报表.xls")，李老师，这是指定了文 ...

Sub gj23w98()
        With Application.FileDialog(msoFileDialogFilePicker)
                .AllowMultiSelect = False
                .Filters.Clear
                .Filters.Add "Excel Files", "*.xls;*.xlsx"
                .Filters.Add "All Files", "*.*"
                If .Show = -1 Then
                        MsgBox "????????????" & .SelectedItems(1), vbOKOnly + vbInformation, "???????"
                End If
        End With
        Set wb = GetObject(Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1))
        Set d = CreateObject("scripting.dictionary")
        With wb
        For Each sht In .Sheets
            If sht.Name <> "????" Then
                With sht
                    arr = .UsedRange
                    For i = 4 To UBound(arr)
                        s = arr(i, 1) & .Name
                        d(s) = arr(i, 2)
                    Next
                End With
            End If
        Next
    End With
    brr = [a1].CurrentRegion
    For i = 7 To UBound(brr)
        For j = 2 To UBound(brr, 2)
            s = brr(i, 1) & Day(brr(1, j))
            If d.exists(s) Then brr(i, j) = d(s)
        Next
    Next
    [a1].CurrentRegion = brr
    Set wb = Nothing
    Set d = Nothing
End Sub

lsc900707

dagal 发表于 2018-7-31 19:04
Set wb = GetObject(ThisWorkbook.Path & "\" & "1807-JZ07客房营业日报表.xls")，李老师，这是指定了文 ...

代码需要审核，请先测试附件：

dagal

lsc900707 发表于 2018-7-31 21:08
代码需要审核，请先测试附件：

李老师，数据提取正常，但是有个问题，就是提取完关闭保存时居然会提示那个日报表是否保存，不论点保存或不保存，再打开这个日报表就整个文件一片灰白，电脑重启后也是一样，我换过可以打开的文档再次操作后问题依旧。不知是什么原因导致的。。。

lsc900707

dagal 发表于 2018-7-31 22:24
李老师，数据提取正常，但是有个问题，就是提取完关闭保存时居然会提示那个日报表是否保存，不论点保存或 ...

我这边没有的问题怎么在你们的电脑上就有问题了，奇怪。代码关闭打开的工作簿看还有没有问题。

dagal

lsc900707 发表于 2018-7-31 23:04
我这边没有的问题怎么在你们的电脑上就有问题了，奇怪。代码关闭打开的工作簿看还有没有问题。

现在ok了，我也是office 2016...搞不懂电脑啥情况！