汇总所有工作簿的工作表中B列最后5行数据，执行到一半就中断了

wjh9239

汇总所有工作簿的工作表中B列最后5行数据，执行到一半就中断了。


每个工作簿名称保存在B列单元格中，B列最后5行数据转置后保存在对应行的右边5列单元格中，程序执行到接近1半的时候就中断了，哪位大侠指点下，多谢啦


Sub HzWb()
Dim bt As Range, r As Long, c As Long
r = 1   '1是表头的行数
c = 7   '7是表头的列数
Dim wt As Worksheet
Set wt = ThisWorkbook.Worksheets(1)         '将汇总表赋给变量wt
wt.Rows(r + 1 & ":1048576").ClearContents   '清除汇总表中原有的数据，只保留表头
Application.ScreenUpdating = False
Dim FrileName As String, sht As Worksheet, wb As Workbook
Dim Erow As Long, fn As String, arr As Variant
Filename = Dir(ThisWorkbook.Path & "\*.xlsx")       '   这是要汇总的工作簿文件的扩展名，只有扩展名为“xlsx”的工作簿中的记录才会被汇总。
Do While Filename <> ""
    If Filename <> ThisWorkbook.Name Then   '判断浙文件是否是汇总数据的工作簿
    Erow = wt.Range("A1").CurrentRegion.Rows.Count + 1  '取得汇总表中第一条空行行号
    fn = ThisWorkbook.Path & "\" & Filename           '将第I个要汇总的工作簿名称赋给变量fn
    Set wb = GetObject(fn)                  '将变量fn代表的工作簿对像赋给变量Wb
    Set sht = wb.Worksheets(1)                  '将要汇总的工作表赋给变量sht
        '将工作表中要汇总的记录保存在数组arr中
        arr = Application.Transpose(sht.Range(sht.Cells(1048576, "B").End(xlUp).Offset(-4, 0), sht.Cells(1048576, "B").End(xlUp)))
    '将数组arr中的数据写入工作表
    wt.Cells(Erow, "A") = "降雨量"
    wt.Cells(Erow, "B") = Left(Filename, InStr(Filename, ".") - 1)
    wt.Cells(Erow, "C").Resize(1, 5) = arr
End If
Filename = Dir      '用Dir函数取得其他文件名，并赋给变量
Loop
Application.ScreenUpdating = True
Call 宏2
End Sub

山菊花

1. Sub HzWb()
   
2.     Dim bt As Range, r As Long, c As Long
   
3.     r = 1   '1是表头的行数
   
4.     c = 7   '7是表头的列数
   
5.     Dim wt As Worksheet
   
6.     Set wt = ThisWorkbook.Worksheets(1)         '将汇总表赋给变量wt
   
7.     wt.UsedRange.Offset(1).ClearContents
   
8.     Application.ScreenUpdating = False
   
9.     Dim FrileName As String, sht As Worksheet, wb As Workbook
   
10.     Dim Erow As Long, fn As String, arr As Variant
    
11.     Filename = Dir(ThisWorkbook.Path & "\*.xlsx")       '   这是要汇总的工作簿文件的扩展名，只有扩展名为“xlsx”的工作簿中的记录才会被汇总。
    
12.     Do While Filename <> ""
    
13.         If Filename <> ThisWorkbook.Name Then   '判断浙文件是否是汇总数据的工作簿
    
14.             r = r + 1
    
15.             fn = ThisWorkbook.Path & "" & Filename           '将第I个要汇总的工作簿名称赋给变量fn
    
16.             Set wb = Workbooks.Open(fn)                  '将变量fn代表的工作簿对像赋给变量Wb
    
17.             Set sht = wb.Worksheets(1)                  '将要汇总的工作表赋给变量sht
    
18.             '将工作表中要汇总的记录保存在数组arr中
    
19.             arr = Application.Transpose(sht.Cells(1048576, "A").End(xlUp).Offset(-4, 1).Resize(5, 1).Value)
    
20.             wb.Close
    
21.             '将数组arr中的数据写入工作表
    
22.             wt.Cells(r, "C").Resize(1, 5) = arr
    
23.         End If
    
24.         Filename = Dir      '用Dir函数取得其他文件名，并赋给变量
    
25.     Loop
    
26.     wt.Range("a2:a" & r).Value = "降雨量"
    
27.     Application.ScreenUpdating = True
    
28.     Call 宏2
    
29. End Sub
    
30. 
    

复制代码

fzxba

2023年2月17日降雨量日特征值.rar (42.86 KB, 下载次数: 17)

2023-2-19 18:39 上传

点击文件名下载附件

zxsea_7426

好花时间啊。



基本重写了。

wjh9239

fzxba 发表于 2023-2-19 18:40

大佬您好，太强大了，好多代码不知道什么意思啊？能加个注释吗？

wjh9239

fzxba 发表于 2023-2-19 18:40

有时候会出现运行错误13，类型不匹配

fzxba

wjh9239 发表于 2023-2-19 21:24
有时候会出现运行错误13，类型不匹配

工作簿名不是  X年X月X日  这样的？

wjh9239

zxsea_7426 发表于 2023-2-19 18:54
好花时间啊。

您好，您发的这个代码我复制粘贴进去，运行提示错误450

1. Sub HzWb_COUNT()
   
2.    t = Timer
   
3.    Application.ScreenUpdating = False
   
4.    Set d = CreateObject("scripting.dictionary")
   
5.    Dim mpath As String, l_r As Long, n As Long
   
6.    Dim rng As Range
   
7.    Dim F As String, sht As Worksheet, wb As Workbook
   
8.    mpath = ThisWorkbook.Path & ""
   
9.    F = Dir(mpath & "*.xlsx")   ' 这是要汇总的工作簿文件的扩展名，只有扩展名为“xlsx”的工作簿中的记录才会被汇总。
   
10.     Do While F <> ""
    
11.    Set wb = Workbooks.Open(mpath & F)
    
12.    l_r = Sheets(1).Cells(Rows.Count, 1).End(3).Row - 4
    
13.   ar = Sheets(1).Cells(l_r, 2).Resize(5, 1)
    
14.   a = Split(Split(F, ".")(0), "年")(0)
    
15.   b = Split(Split(Split(F, ".")(0), "年")(1), "月")(0)
    
16.   c = Split(Split(Split(Split(F, ".")(0), "年")(1), "月")(1), "日")(0)
    
17.   d(F) = Array(Application.Transpose(ar), DateSerial(Val(a), Val(b), Val(c)))
    
18.   wb.Close False
    
19.   F = Dir '用Dir函数取得其他文件名,并赋给变量
    
20. Loop
    
21.   With ActiveSheet
    
22.       .UsedRange.Offset(1).ClearContents '清除汇总表中原有的数据, 只保留表头
    
23.       For Each Key In d.keys
    
24.            Set rng = .Cells(Rows.Count, 1).End(3).Offset(1, 0)
    
25.            rng.Value = "降雨量"
    
26.            rng.Offset(0, 2).Resize(1, 5) = Application.Transpose(Application.Transpose(d(Key)(0)))
    
27.            rng.Offset(0, 1) = d(Key)(1)
    
28.       Next
    
29.     With .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(3).Offset(0, 6))
    
30.        .Font.Size = 10
    
31.        .Borders.LineStyle = 1
    
32.     End With
    
33.     End With
    
34.     ActiveSheet.Range(ActiveSheet.Cells(2, 1), ActiveSheet.Cells(Rows.Count, 1).End(3).Offset(0, 6)).Sort keyl:=ActiveSheet
    
35.     Application.ScreenUpdating = True
    
36.      MsgBox "汇总完毕,共计耗时:" & Format(Timer - t, "0.0000") & "秒"
    
37. End Sub

复制代码

wjh9239

fzxba 发表于 2023-2-19 21:32
工作簿名不是  X年X月X日  这样的？

是的，看起来都是一样的

fzxba

wjh9239 发表于 2023-2-19 21:50
是的，看起来都是一样的

小问题了，可以变通的。