修改代码

lgzxmlg

跨工作薄多表取数，因源文件名会变化，如何以关键字为文件名进行取数，或以单元名内容为文件名进行取数？Sub test()
    Dim arr, i, p$, sh As Worksheet
    p = ThisWorkbook.Path & "\2018年1月份经营报表.xls"
    With GetObject(p)
        n = .Worksheets.Count
        ReDim arr(1 To n, 1 To 36)
        For Each sh In .Worksheets
            With sh
             If sh.Name Like "*日" Then
                i = i + 1
arr(i, 1) = .[a3]
arr(i, 2) = .[e55]
arr(i, 3) = .[e56]
arr(i, 4) = .[e57]
arr(i, 5) = .[e58]
arr(i, 6) = .[e59]
arr(i, 7) = .[e60]
arr(i, 8) = .[e61]
arr(i, 9) = .[e62]
arr(i, 10) = .[e63]
arr(i, 11) = .[e64]
arr(i, 12) = .[e65]
arr(i, 13) = .[e66]
arr(i, 14) = .[e67]
arr(i, 15) = .[e68]
arr(i, 16) = .[e69]
arr(i, 17) = .[e70]
arr(i, 18) = .[e71]
arr(i, 19) = .[e72]
arr(i, 20) = .[e39]
arr(i, 21) = .[e40]
arr(i, 22) = .[e41]
arr(i, 23) = .[e42]
arr(i, 24) = .[e43]
arr(i, 25) = .[e44]
arr(i, 26) = .[e45]
arr(i, 27) = .[e46]
arr(i, 28) = .[e48]
arr(i, 29) = .[e49]
arr(i, 30) = .[e50]
arr(i, 31) = .[e51]
arr(i, 32) = .[e52]
arr(i, 33) = .[k72]
arr(i, 34) = .[l72]
arr(i, 35) = .[m72]
arr(i, 36) = .[n72]
            End If
            End With
        Next
        .Close 0
    End With
    With Sheet2
         Sheet2.Range("A3:AX34").ClearContents
        .[a3].Resize(UBound(arr), 36) = arr
          Range("a" & i + 4) = "合计"
         Range("b" & i + 4 & ":aj" & i + 4).Formula = "=sum(b4:b" & i + 1 & ")"
    End With
End Sub

Sub 生产统计3()

jiangxiaoyun

将那些连续的单元格改为for循环吧。。。

蓝桥玄霜

没有附件不能测试代码。
建议上传Excel表格附件来说明问题。

jiangxiaoyun

用变量代替文件名称
假如是单元格A1，则  s=[A1].VALUE
p = ThisWorkbook.Path & "\" & S

另外可以用inputbox函数来处理

具体，自己百度一下，啥都有。
不会改代码就算了。

lgzxmlg

蓝桥玄霜 发表于 2018-1-21 09:41
没有附件不能测试代码。
建议上传Excel表格附件来说明问题。

跨工作薄取数求助.zip (663.42 KB, 下载次数: 4)

2018-1-21 09:51 上传

点击文件名下载附件

lgzxmlg

已解决，先提取包含特定字符的文件名。
不知下面代码是否还能优化？
Sub 取数()
    Dim arr, i, p$, sh As Worksheet, f, str
    tt = MsgBox("参与取数的文件必须与本工作薄处于同一文件夹下，否则，无法取数！" & Chr(10) & Chr(10) & _
    "是否继续？", vbQuestion + vbYesNo, "提示")
    For Each f In CreateObject("scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files
  If f Like "*[年]*.xls" Then str = str & IIf(str = "", "", ";") & f
   Next
  a = Replace(Replace(str, ".xls", ""), ThisWorkbook.Path & "\", "")
    p = ThisWorkbook.Path & "\" & a & ".xls"
    With GetObject(p)
        n = .Worksheets.Count
        ReDim arr(1 To n, 1 To 36)
        For Each sh In .Worksheets
            With sh
             If sh.Name Like "*日" Then
                i = i + 1
arr(i, 1) = .[a3]
arr(i, 2) = .[e55]
arr(i, 3) = .[e56]
arr(i, 4) = .[e57]
arr(i, 5) = .[e58]
arr(i, 6) = .[e59]
arr(i, 7) = .[e60]
arr(i, 8) = .[e61]
arr(i, 9) = .[e62]
arr(i, 10) = .[e63]
arr(i, 11) = .[e64]
arr(i, 12) = .[e65]
arr(i, 13) = .[e66]
arr(i, 14) = .[e67]
arr(i, 15) = .[e68]
arr(i, 16) = .[e69]
arr(i, 17) = .[e70]
arr(i, 18) = .[e71]
arr(i, 19) = .[e72]
arr(i, 20) = .[e39]
arr(i, 21) = .[e40]
arr(i, 22) = .[e41]
arr(i, 23) = .[e42]
arr(i, 24) = .[e43]
arr(i, 25) = .[e44]
arr(i, 26) = .[e45]
arr(i, 27) = .[e46]
arr(i, 28) = .[e48]
arr(i, 29) = .[e49]
arr(i, 30) = .[e50]
arr(i, 31) = .[e51]
arr(i, 32) = .[e52]
arr(i, 33) = .[k72]
arr(i, 34) = .[l72]
arr(i, 35) = .[m72]
arr(i, 36) = .[n72]
            End If
            End With
        Next
        .Close 0
    End With
    With Sheet2
         Sheet2.Range("A3:AX34").ClearContents
        .[a3].Resize(UBound(arr), 36) = arr
          Range("a" & i + 4) = "合计"
         Range("b" & i + 4 & ":aj" & i + 4).Formula = "=sum(b4:b" & i + 1 & ")"
    End With
End Sub

abc123281

你的分表与汇总表格式不一致    所以汇总很麻烦

abc123281

看不明白你要干什么  
     建议重新整理附件   把分表中要复制汇总表的数据单元格标色     并说明你想要达到的效果   才有老师会帮助你实现