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

魂断蓝桥

dagal 发表于 2018-7-25 18:47
大神，这个在03版下可以吗？我没测试过。。。

03可以的。

dagal

魂断蓝桥 发表于 2018-7-26 09:28
03可以的。

test.rar (104.24 KB, 下载次数: 3)

2018-7-27 15:09 上传

点击文件名下载附件

老师，我同样也是用你的方法在另外一个表里做修改后，执行时出错了。麻烦您帮忙看看，谢谢了！错误提示如下：

魂断蓝桥

dagal 发表于 2018-7-27 15:13
老师，我同样也是用你的方法在另外一个表里做修改后，执行时出错了。麻烦您帮忙看看，谢谢了！错误提 ...

Sub tqsj()
Dim f
f = Application.GetOpenFilename("EXCEL Files (*.xls), *.xls")
If f = False Then Exit Sub
Dim cnn As Object
Dim Sql As String, i%, arr, rs
Set cnn = CreateObject("ADODB.CONNECTION")
Set rs = CreateObject("adodb.Recordset")
cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=YES'; Data Source=" & f
For i = 1 To 31
     Sql = Sql & "select 收入+0 from [" & i & "$a6:b28] where 销售='Total Room Sales房费:' or 销售='会议费' or 销售='迷你吧' or 销售='洗涤费' or 销售='杂项'or 销售='赔偿费' or 销售='西餐厅' UNION ALL "
Next
Sql = Left(Sql, Len(Sql) - 11)
rs.Open Sql, cnn, 1, 1
[b2:af12] = ""
For i = 1 To 31
     [a2].Offset(0, i).CopyFromRecordset rs, 7
Next
cnn.Close: Set cnn = Nothing
End Sub

魂断蓝桥

代码审核中，上个附件

a.rar (106.59 KB, 下载次数: 24)

2018-7-27 16:02 上传

点击文件名下载附件

dagal

魂断蓝桥 发表于 2018-7-27 16:02
代码审核中，上个附件

收到。但我想知道下面2句是啥意思呢，烦指教一下，谢谢。
Sql = Left(Sql, Len(Sql) - 11)
rs.Open Sql, cnn, 1, 1

dagal

魂断蓝桥 发表于 2018-7-27 16:00
Sub tqsj()
Dim f
f = Application.GetOpenFilename("EXCEL Files (*.xls), *.xls")

大神，有个问题，就是提取完数据后从A7到A14这几行数据也自动清空，能否不清空底下几行的数据呢？谢谢

魂断蓝桥

dagal 发表于 2018-7-27 16:26
收到。但我想知道下面2句是啥意思呢，烦指教一下，谢谢。
Sql = Left(Sql, Len(Sql) - 11)
rs.Open S ...

前面的循环 都加入了 UNION ALL 这一句，循环后需要清除这个，所以需要-11个字符。

魂断蓝桥

dagal 发表于 2018-7-30 10:02
大神，有个问题，就是提取完数据后从A7到A14这几行数据也自动清空，能否不清空底下几行的数据呢？谢谢

[b2:af12] = ""

这句代码自己根据需要修改就行了。

dagal

嗯，可以了，谢谢

lsc900707

字典能解决这个问题，但名称要求统一：
Sub gj23w98()
    Set wb = GetObject(ThisWorkbook.Path & "\" & "1807-JZ07客房营业日报表.xls")
    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