[VBA特2期]练习2:多文件汇总

wbzxz

<div>我的天，这么多雷。累死我啦。运行1.5秒，不知道行不？</div><div><br/></div>

游客，如果您要查看本帖隐藏内容请回复

</div><br/>

wbzxz

<div class="msgheader">QUOTE:</div><div class="msgborder"><b>以下是引用<i>raulerini</i>在2010-12-7 13:06:00的发言：</b><br/><p>第一次提速。</p><p></p></div><p>呵呵，你的程序在我的机子上，只需要0.7秒啊</p>

wbzxz

<div>呵呵，这次也学习着提了一下速，减少了一半的循环，速度提升了近一半</div><div><br/></div><div><br/></div>

游客，如果您要查看本帖隐藏内容请回复

wbzxz

<div>呵呵，又排了一颗雷，取巧了一下，减少了些循环，速度提升了一点点。</div><div><br/></div><div><br/></div><br/><br/>

[此贴子已经被作者于2010-12-9 23:12:06编辑过]

lyn666666

游客，如果您要查看本帖隐藏内容请回复

tgtool

kankan

zfc7777

看答案

erqiran

我来看看答案

龙猫

<p>

游客，如果您要查看本帖隐藏内容请回复

</p>

lyn666666

修改后：
Sub myre()
Dim d As New Dictionary, i%, j As Byte, arr, temp(1 To 1000, 1 To 7), k%, x%, s As String, y As Byte, t
Dim fpath As String, fname As String, wkb As Workbook, sht As Worksheet, arrBT, str As String, Erow%
Application.ScreenUpdating = False
t = Timer
arrBT = Array("考号", "姓名", "语文", "数学", "英语", "政治", "历史")    '结果表的表头
s = "语数英政历"
Sheet3.UsedRange.ClearContents
Sheet3.Range("A1:G1") = arrBT
fpath = ThisWorkbook.Path & "\收\"
fname = Dir(fpath & "\*.xls")
Do While fname <> ""
    Set wkb = Workbooks.Open(fpath & fname)
    For Each sht In wkb.Worksheets
        sht.Select
        arr = Range("A1").CurrentRegion
        For i = 2 To UBound(arr)
            If Len(CStr(arr(i, 1))) <> 8 Then
                str = Range("A" & i).NumberFormat
                arr(i, 1) = CLng(str) + arr(i, 1)
            End If
            If Not d.Exists(arr(i, 1)) Then
                k = k + 1
                d.Add arr(i, 1), k
                x = k
                temp(x, 1) = arr(i, 1)
                temp(x, 2) = arr(i, 2)
            Else
                x = d(arr(i, 1))
            End If
            For j = 3 To UBound(arr, 2)
                y = InStr(1, s, Left(arr(1, j), 1)) + 2
                temp(x, y) = arr(i, j)
            Next
        Next
    Next
    fname = Dir
    wkb.Close False
    Erase arr
Loop
Range("A2").Resize(UBound(temp), UBound(temp, 2)) = temp
Erow = [A65536].End(3).Row
Range("A1").Select
    Range("A1:G" & Erow).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
MsgBox Timer - t
Application.ScreenUpdating = True
End Sub