欢迎参加“报表汇总之星”v1.2的测试

lyou99015

<p>真是扳扎！谢谢</p>

v888qq

我来试试看

qhy905

好11111111

杨成云

　　本人自行添加了“保区/读区（保存选择区域、读取选择区域）、列表框自动汇总功能
　　但有一小点问题没解决：在“读取选择区域”前要先用鼠标选取一下“RefEdit控件”，这样才不会出错，本来是用 refAddress.SetFocus来激活这个控件来达到目的，但想不到不成功！


Private Sub 创建文件_Click()
    Dim fso As New FileSystemObject
    Dim oStream As TextStream
    Dim sFName As String, iFNumber As Integer, r As Long
    sFName = "一片白云"
    sFName = ThisWorkbook.Path & "\" & sFName & ".txt"
    iFNumber = FreeFile '获取可用文件号
    Open sFName For Output As #iFNumber '用Output方式打开文件
    'For PL = 1 To lstRange.ListCount
        'Write #iFNumber, lstRange.List(PL - 1) '向文件中写入数据
    'Next
    Close #iFNumber '关闭文件
    Set oStream = fso.OpenTextFile(filename:=sFName, IOMode:=ForAppending)
    For PP = 1 To lstRange.ListCount
        oStream.WriteLine lstRange.List(PP - 1) '向文件中写入数据
    Next PP
   
    oStream.Close   '关闭文本流对象
    Set oStream = Nothing
    Set fso = Nothing
End Sub
Private Sub 提取区域_Click()
    lstRange.Clear
    RenewTotalRanges
    refAddress.SetFocus
    Dim str1 As String, sFName As String, iFNumber As Integer, r As Long
    Dim strRg As String
    sFName = "一片白云"
    sFName = ThisWorkbook.Path & "\" & sFName & ".txt"
    If sFName = "False" Then Exit Sub
    iFNumber = FreeFile     '获取可用文件号
    Open sFName For Input As #iFNumber      '用Input方式打开文件
    r = 2
    Do
        Line Input #iFNumber, str1
        lstRange.AddItem str1, r - 2
        strRg = lstRange.List(r - 2)
        r = r + 1
    Loop Until EOF(iFNumber)
    Close #iFNumber '关闭文件
    For LK = 1 To lstRange.ListCount
        TotalRanges.Add lstRange.List(LK - 1)
    Next
    ShowObjranges
End Sub

[ 本帖最后由 杨成云 于 2009-9-1 11:18 编辑 ]

杨成云

将楼主的部分代码作如下修改，就可以实现连续汇总（列表框区域自动选取并汇总）
Private Sub Total()
    '根据数据数据源的不同，首先将数据源名放到数组中
    '
    '然后在Totalrange集合中的元素逐一取出与数据源结合
    '
    '调用合并计算方法，计算结果放至sheet1
    '
    '复制结果，粘贴值至目标区域
'    On Error GoTo HUIZONG_ERROR
    Dim arySource() As String
    Dim Sourcename As String
    Dim UpLeftCell As String
    Dim ifileCount As Integer
    Dim iRngCount As Integer
    Dim R1C1Style As String
    Dim IsFlag As Integer
    Dim i As Integer
    Dim j As Integer
   
    For j = 1 To lstRange.ListCount
     '错误防止条件
     If Workbooks.count = 0 Then Exit Sub
     If TotalRanges Is Nothing Then Exit Sub
     If TotalRanges.IsEmpty Then Exit Sub
     
     'If lstRange.ListIndex < 0 Then
         'MsgBox "请单击选择汇总区域，本程序尚不能同时汇总多个区域。", vbInformation, "抱歉"
        ' lstRange.SetFocus
         'Exit Sub
    ' End If
     
     If chkFlag.Value = True Then
         IsFlag = 1
     Else
         IsFlag = 0
     End If
     
     If eSourceFrom = FromBooks Then
         If colFiles Is Nothing Then Exit Sub
         If colFiles.count < 1 Then Exit Sub
         ReDim arySource(colFiles.count - 1)
         Sourcename = ""
         For i = 0 To colFiles.count - 1
             arySource(i) = "'" & Sourcename & colFiles(i + 1) & "'!"
         Next i
     Else
         If TotalSheets Is Nothing Then Exit Sub
         If TotalSheets.IsEmpty Then Exit Sub
         
         ReDim arySource(TotalSheets.count - 1)
         
         Sourcename = "[" & ActiveWorkbook.Name & "]"
         
         For i = 0 To TotalSheets.count - 1
             arySource(i) = "'" & Sourcename & TotalSheets.GetShtName(i + 1) & "'!"
         Next i
     End If
     iRngCount = TotalRanges.RangeCount
             lstRange.Selected(j - 1) = True
             'j = lstRange.ListIndex + 1
             R1C1Style = A1ToR1C1(TotalRanges.Ranges(j))
             UpLeftCell = GetUpLeftA1Style(TotalRanges.Ranges(j))
             For i = LBound(arySource) To UBound(arySource)
                 arySource(i) = arySource(i) & R1C1Style
             Next i
         With Sheet1
             .Cells.Clear
             .Range(UpLeftCell).Consolidate Sources:=arySource(), Function:=GetFunction, _
             Toprow:=optTop * IsFlag, LeftColumn:=optLeft * IsFlag, CreateLinks:=False
             .UsedRange.Copy
     '        .Range (UpLeftCell)
         End With
         ActiveSheet.Range(UpLeftCell).PasteSpecial xlPasteValues
         Application.CutCopyMode = xlCut
Next j

'    Unload Me
Get_A_Error:
    Exit Sub
   
HUIZONG_ERROR:
    MsgBox "汇总文件错误，不能进行汇总！" & Chr(10) & "可能是以下原因造成的：" _
    & Chr(10) & "1、汇总源文件重复；" & Chr(10) & "2、目标工作表已设置保护。", _
    vbExclamation, "WANNING!"
    Resume Get_A_Error
End Sub

[ 本帖最后由 杨成云 于 2009-9-1 11:23 编辑 ]

yajun_wang888

我来试试看

yajun_wang888

有点晕，看不懂。太强了。

yanxiaowai1000

赞赞赞赞赞赞赞赞赞赞赞赞赞赞赞！

358928505

顶 有没有
所有打开工作表复制到一个工作簿中的宏啊

ximeir

谢谢楼主了，很好用也帮我大忙了