求租提取所有文件夹中同一列数据生成一张汇总报表

dagal

魂断蓝桥 发表于 2018-7-13 14:52
以你的附加测试没有问题。
第四行的每一列自动提取场所代码 ，没看懂，你这个是合计的数值（一个值是16 ...

我是win7 office 2016版的。不知为何就是出错了。。。

dagal

你是用的sql数据库链接？我电脑没装sql数据库啊。。。能否改为不用数据库链接的方式

dagal

有没有不用SQL数据库连接来解决的办法，谢谢各位~~~~

lsc900707

Sub gj23w98()
    Dim arr()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheet1.Range("c4:r" & Rows.Count).ClearContents
    p = ThisWorkbook.Path & "\"
    f = Dir(p, vbDirectory)
    Do While f <> ""
        If f <> "." And f <> ".." Then
            If (GetAttr(p & f) And vbDirectory) = vbDirectory Then
                m = m + 1
                ReDim Preserve arr(m)
                arr(m) = p & f & "\"
            End If
        End If
        f = Dir
    Loop
    For j = 1 To m
        f = Dir(arr(j) & "*.xls")
        While f <> ""
            Set wb = CreateObject(arr(j) & f)
            With wb.Sheets(1)
                 ar = .[c5:c65]
            End With
            Sheet1.Cells(5, 3 + n).Resize(61) = ar
            Sheet1.Cells(4, 3 + n) = Replace(Split(Split(f, ".")(0), "-")(1), "表", "")
            n = n + 1
            wb.Close False
            f = Dir()
        Wend
    Next
    Set wb = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

lsc900707

附件供测试参考：

jjmysjg

lsc900707 发表于 2018-7-14 07:39
附件供测试参考：

执行代码，提示“不能对合并单元格做部分更改”
麻烦看看
谢谢

lsc900707

jjmysjg 发表于 2018-7-14 09:38
执行代码，提示“不能对合并单元格做部分更改”
麻烦看看
谢谢

下载测试附件。我测试运行正常。

jiminyanyan

jjmysjg 发表于 2018-7-14 09:38
执行代码，提示“不能对合并单元格做部分更改”
麻烦看看
谢谢

Dim lr
    lr = Sheet1.Range("c65535").End(xlUp).Row
    Sheet1.Range("c4:r" & lr).ClearContents

jjmysjg

lsc900707 发表于 2018-7-14 09:50
下载测试附件。我测试运行正常。

谢谢，汇总表B66是合并单元格，我这2007版本不能继续。取消合并就可以了

jjmysjg

jiminyanyan 发表于 2018-7-14 09:55
Dim lr
    lr = Sheet1.Range("c65535").End(xlUp).Row
    Sheet1.Range("c4:r" & lr).ClearContents

谢谢，B66是合并单元格，为啥改了你的几句，就可以了？