汇总数据

阿煮

规则：本文件夹内所有文件的B列数据汇总到总表的BCDFG列等等(根据A列的ID号),以此类推。比如水域表格.xlsx，A列的ID是105，则B列数据写入到总表ID是105的那一行；水域表格中ID为0-104的没有，则总表的ID 是0-104的空着。公式的话用vlookup实现。实际文件比较多，也大，文件夹的文件瘦身过了。代码写了，但是我写的代码运行很慢。请问有什么快的解法。谢谢~VBA才开始学，小白。

shiruiqiang

直接遍历文件+字典

shiruiqiang

Sub text()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim f, fso
Dim dic, key
Dim arr, brr
Dim x, i, y
Set fso = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")

For Each f In fso.getfolder(ThisWorkbook.Path).Files
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    With Workbooks.Open(f)
        arr = .Sheets(1).UsedRange
        .Close False
    End With
    For x = 2 To UBound(arr)
    key = arr(x, 1) & "|" & arr(1, 2)
    dic(key) = arr(x, 2)
    Next x
End If
Next
brr = Sheets("»ã×ü").[a1].CurrentRegion
For i = 2 To UBound(brr)
For y = 2 To 3
key = brr(i, 1) & "|" & brr(1, y)
brr(i, y) = dic(key)
Next
Next
Sheets("汇总").[a1].CurrentRegion = brr
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

阿煮

shiruiqiang 发表于 2022-12-18 20:25
直接遍历文件+字典

听朋友讲字典是会快，在学字典，能否发下代码的txt版本呢，谢谢

shiruiqiang

阿煮 发表于 2022-12-18 20:29
听朋友讲字典是会快，在学字典，能否发下代码的txt版本呢，谢谢

等审核吧

zxsea_7426

我写的用字典，好像时间也不短啊.....................

楼主的代码用时：

我写的用字典耗时:

skyzxh

采用数组+字典应该可以快不少。

阿煮

skyzxh 发表于 2022-12-18 21:05
采用数组+字典应该可以快不少。

万分感谢，测试运行下来ok的。我买的入门视频课程里面没有字典的相关的讲解。网上搜索的比较碎，这样的字典的课程推荐看谁的课程好些呢。在尝试看字典的定义来理解。只记得看入门课时候老师讲的，写入都慢。但是数组之类的就快。

zxsea_7426

shiruiqiang 发表于 2022-12-18 20:25
直接遍历文件+字典

为啥你的代码运行时间比楼主的代码运行时间还长?

gwjkkkkk

Sub TEST()
    Dim strFileName$, strPath$, wkb As Workbook
    Dim arr, i&, j&, t#
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
    [A1].CurrentRegion.Offset(1, 1).Clear
    [A1].CurrentRegion.Offset(1, 1).NumberFormatLocal = "0.00000000000"
    arr = [A1].CurrentRegion
    For i = 2 To UBound(arr): dic(arr(i, 1)) = i: Next i
    For i = 2 To UBound(arr, 2): dic(arr(1, i)) = i: Next i
   
    strPath = ThisWorkbook.Path & "\"
    For i = 2 To UBound(arr, 2)
          strFileName = Dir(strPath & "*" & arr(1, i) & "*")
          Set wkb = GetObject(strPath & strFileName)
              With wkb
                brr = .Sheets(1).[A1].CurrentRegion
                For j = 2 To UBound(brr)
                   If dic.exists(brr(j, 1)) Then
                      arr(dic(brr(j, 1)), dic(arr(1, i))) = brr(j, 2)
                   End If
                Next j
              End With
          wkb.Close False
      Next i

    [A1].CurrentRegion = arr
    Set wkb = Nothing
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
    Beep

End Sub