求助前辈高手们优化提高代码运行效率！

追风坊

因数据源里面文件多达50个，需要进行复制汇总，如会频繁地打开关闭工作簿，运行时间很长，请大家帮忙修改，以提升运行速度，具体代码如下：

Sub cpAllSingle()
    Call cpSingle("S1", 5, 3, 26)
    Call cpSingle("S4", 5, 3, 7)
    Call cpSingle("S7", 5, 3, 10)
    Call cpSingle("S8", 5, 3, 12)
    Call cpSingle("S9", 5, 3, 17)
    Call cpSingle("K1", 5, 3, 35)
    Call cpSingle("K2", 5, 3, 43)
    Call cpSingle("K2-1", 5, 3, 14)
    Call cpSingle("K3", 5, 3, 32)
    Call cpSingle("K4", 5, 3, 22)
    Call cpSingle("K5", 5, 3, 13)
    Call cpSingle("K6", 5, 3, 15)
    Call cpSingle("K7", 5, 3, 13)
    Call cpSingle("K8", 5, 3, 13)
    Call cpSingle("K9", 5, 3, 14)
    Call cpSingle("K10", 5, 3, 30)
   
End Sub

Sub cpAllFlex()
    Call cpFlex("S2", 5, 10, 21)
   
   
End Sub

Sub cpAllDynalRow()
    Call cpDynalRow("k2-2", 5, 5)
    Call cpDynalRow("k3-1", 5, 7)
    Call cpDynalRow("k10-1", 5, 7)
    Call cpDynalRow("k12-1", 5, 9)
    Call cpDynalRow("k14-1", 5, 9)

   
End Sub

Sub cpSingle(ByVal sheetName As String, ByVal mcRow As Integer, ByVal mcCol As Integer, ByVal lastRow As Integer)
    Application.ScreenUpdating = False
    Dim r&, col&, i%, mypath$, nm$, arr, shnm$, wb As Workbook, sh As Worksheet, mc$
    mypath = ThisWorkbook.Path & "\数据源\"
   
    Set wb = ThisWorkbook
    Set sh = wb.Sheets(sheetName)
    sh.Cells(lastRow + 1, 1).Resize(1000, 1000).Clear
    nm = Dir(mypath & "*.xlsx")
    Do While nm <> ""
        With GetObject(mypath & nm)
        If isEmptySingle(.Sheets(sheetName), lastRow, mcCol) <> True Then
            mc = Split(nm, ".")(0)
            col = sh.Cells(mcRow, sh.Columns.Count).End(xlToLeft).Column + 1
            .Sheets(sheetName).Cells(mcRow, mcCol).Resize(lastRow - mcRow + 1, 1).Copy sh.Cells(mcRow, col).Resize(lastRow - mcRow + 1, 1)
            sh.Cells(mcRow, col) = mc
            End If
            .Close 0
        End With
        nm = Dir
    Loop
    With sh
        offsetCol = .Cells(mcRow, sh.Columns.Count).End(xlToLeft).Column - mcCol
      For i = mcRow + 1 To lastRow
        .Cells(i, mcCol).Resize(1, 1).FormulaR1C1 = "=sum(rc[1]:rc[" & offsetCol & "])"
      Next
    End With
    Application.ScreenUpdating = True
End Sub

Sub cpFlex(ByVal sheetName As String, ByVal startRow As Integer, ByVal endCol As Integer, ByVal lastRow As Integer)
    Application.ScreenUpdating = False
    Dim r&, col&, i%, mypath$, nm$, arr, shnm$, wb As Workbook, sh As Worksheet, mc$, row&
    mypath = ThisWorkbook.Path & "\数据源\"
   
    Set wb = ThisWorkbook
    Set sh = wb.Sheets(sheetName)
    sh.Cells(lastRow + 1, 1).Resize(1000, 1000).Clear
    nm = Dir(mypath & "*.xlsx")
    Do While nm <> ""
        With GetObject(mypath & nm)
         If isEmpty(.Sheets(sheetName), lastRow, endCol) <> True Then
            mc = Split(nm, ".")(0)
            row = sh.Cells(sh.Rows.Count, 1).End(xlUp).row + 2
            sh.Cells(row, 1) = mc
            .Sheets(sheetName).Cells(startRow, 1).Resize(lastRow - startRow + 1, endCol).Copy sh.Cells(row + 1, 1).Resize(lastRow - startRow + 1, endCol)
           End If
            .Close 0
        End With
        nm = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Sub cpDynalRow(ByVal sheetName As String, ByVal titleRow As Integer, ByVal maxCol As Integer)
   Application.ScreenUpdating = False
    Dim r&, col&, i%, mypath$, nm$, arr, shnm$, wb As Workbook, sh As Worksheet, mc$, contentRows&, tmpRow&
    mypath = ThisWorkbook.Path & "\数据源\"
    Set wb = ThisWorkbook
    Set sh = wb.Sheets(sheetName)
    nm = Dir(mypath & "*.xls")
    startRow = titleRow + 1
   
   Do While nm <> ""
   With GetObject(mypath & nm)
    lastRow = .Sheets(sheetName).Cells(.Sheets(sheetName).Rows.Count, 1).End(xlUp).row
    If isEmpty(.Sheets(sheetName), lastRow, maxCol) <> True Then
    .Sheets(sheetName).Cells(titleRow + 1, 1).Resize(lastRow - titleRow, maxCol).Copy sh.Cells(startRow, 1).Resize(lastRow - titleRow, maxCol)
    startRow = startRow + lastRow - titleRow - 1
    End If
    .Close 0
   End With
    nm = Dir
   Loop
   sh.Cells(startRow, maxCol).Resize(1).FormulaR1C1 = "=sum(r[-1]c:r[" & titleRow - startRow + 1 & "]c)"
   Application.ScreenUpdating = True
End Sub

Function isEmpty(ByVal sh As Worksheet, ByVal endRow As Integer, ByVal endCol As Integer) As Boolean
            For row = 1 To endRow
                For col = 1 To endCol
                    If sh.Cells(row, col).HasFormula And sh.Cells(row, col) <> 0 Then
                    isEmpty = False
                    Exit Function
                    End If
                Next
            Next
            isEmpty = True
End Function

Function isEmptySingle(ByVal sh As Worksheet, ByVal endRow As Integer, ByVal col As Integer) As Boolean
            For row = 1 To endRow
                    If sh.Cells(row, col).HasFormula And sh.Cells(row, col) <> 0 Then
                    isEmptySingle = False
                    Exit Function
                    End If
            Next
            isEmptySingle = True
End Function

yiyiyicz

似乎关键是在前面的call
可以用委托的方法，

编程：
1，建立接口，虚拟类
添加类模块“InterFace”,在类模块中写入
Private Sub CallFun(需要的参数列表)
（空）
End Sub
2，为每个函数，逐个建立实现类模块
类模块名称就是将来调用函数的名称
在类模块中写入：
Implements InterFace
根据下拉菜单的sub过程
在过程中写入函数表达式
3，在标准模块中，用function
写求解方法，写入此
其中涉及的函数用回调函数的方法
Public Sub MainFun(Fun As InterFace, x As Double, y As Double, ret As Double)
    Fun.CallFun x, y, ret
    Fun.Callfun1 x, y, ret
End Sub
4，在主程序中
两个for next 循环
当搜索到有根区间后，进入3的求根过程
求解结果（根）带回，存入数组，并处理
排序
求出两个变位系数

在类中为自己建立集合
    回调函数

这是我自己写的一段笔记
在EH中，我贴过很长的实例代码
不知什么原因，我无法搜索

yiyiyicz

最简单的方法，用select case
虽然有点麻烦，也不利于扩展，但是也很实用

jpj123

可以考虑用SQL解决

ak47ok

学习中。每次回帖、谢谢！辛苦了。

追风坊

yiyiyicz 发表于 2015-4-27 06:27
似乎关键是在前面的call
可以用委托的方法，

请问，把   .Close 0 去掉，不频繁打开或关闭目标工作簿，会不会提示速度？或者请问有什么具体的办法，可以先执行完一个工作簿的所有call，再打开下一个工作簿呢？请不吝赐教。

yiyiyicz

“会不会提示速度？”
不会提示速度，但理论上影响速度。实际当中影响多少，你在乎时间到什么程度，则是另外的问题。
“可以先执行完一个工作簿的所有call，再打开下一个工作簿呢？”
所有的call是个含糊概念，如果是集合中所有的对象，常用for each ... in这样的语句（配合if then语句也可以对集合中的某些操作），但问题是你还有自定义函数，关键是UDF中还有参数变量，这些参数变量本身又是函数，这才是难点