字典搭配数组，输出问题

simic1989

自己做了个批量取数的宏，摘取各月份表中相应的数据。
字典里的一个key对应的items是一个数组。数组里是1-12个月的数据。有些月份没数据数组就留空。
但是我最后输出字典内容的时候失败。可能我这个字典对应数组写的就不对。请老师能指教一下吗。

蓝桥玄霜

如果各个工作簿的A列分行的内容都是一样的位置，就连字典都不需要用，直接复制过来即可。
ThisWorkbook.Sheets(sName).[a2].Resize(dic.Count, j) = Application.Rept(dic.items, 1)这句错误。

simic1989

蓝桥玄霜 发表于 2019-10-16 11:13
如果各个工作簿的A列分行的内容都是一样的位置，就连字典都不需要用，直接复制过来即可。
ThisWorkbook.Sh ...

版主你好，每个表中A列内容是不一样的，因为存在某个月没数据的情况。老师能帮忙改一下输出字典的这句语句吗。

opel-wong

simic1989 发表于 2019-10-16 11:25
版主你好，每个表中A列内容是不一样的，因为存在某个月没数据的情况。老师能帮忙改一下输出字典的这句语 ...

你这逻辑有问题，
你是想取所有月份的数据，还是只取一个月份的数据？
如果是所有月份，那么这句： If sht.Name = sName Then
就限制了，，，因为这个工作表名，只有“2月.xlsx”这个工作薄中才有，
所以，，，你把你的要求说清楚就可以了，

simic1989

opel-wong 发表于 2019-10-16 11:43
你这逻辑有问题，
你是想取所有月份的数据，还是只取一个月份的数据？
如果是所有月份，那么这句： If  ...

我是想取所有的月份，而且并非是每个月都有相应的表，所以我加了那条限定，如果那个月的工作簿中没有符合条件的表，取出的数据就是0.

opel-wong

simic1989 发表于 2019-10-16 12:29
我是想取所有的月份，而且并非是每个月都有相应的表，所以我加了那条限定，如果那个月的工作簿中没有符合 ...

在“模板”表中输出结果，看看是不是这个效果？

opel-wong

代码基础上重新写了，
请测试：

feiyang8878

新手回复一下，初学两个月，请各位老师帮忙指导，测试可以达到效果

feiyang8878

opel-wong 发表于 2019-10-16 15:05
代码基础上重新写了，
请测试：

老师，你的运行需要多少秒，我根据我写的和你的对比一下

opel-wong

simic1989 发表于 2019-10-16 12:29
我是想取所有的月份，而且并非是每个月都有相应的表，所以我加了那条限定，如果那个月的工作簿中没有符合 ...

代码如下：

1. Sub text()
   
2.     Dim wb As Workbook, sht As Worksheet, mYp$, mYn$, i%, j%, Rol%, Col$, sName$, mRow%, bm$, mCol%, mStr$
   
3.     Application.DisplayAlerts = False: Application.ScreenUpdating = False
   
4.     Dim d As Object: Set d = CreateObject("scripting.dictionary")
   
5.     Dim T1 As Date: T1 = Timer    ' 记时
   
6.     Dim TheBook As Workbook: Set TheBook = ThisWorkbook
   
7.     Dim TheSheet As Worksheet: Set TheSheet = TheBook.Sheets("程序")
   
8.     With TheSheet
   
9.         sName = .Range("b3").Value    ' 抓取数据表名称
   
10.         Col = .Range("b4").Value         ' 数据所在列
    
11.         Rol = .Range("b5").Value         ' 数据起始行
    
12.         mCol = .Columns(Col).Column  ' 转换列号
    
13.     End With
    
14.     mYp = TheBook.Path & "\"
    
15.     mYn = Dir(mYp & "*.xls*")
    
16.     Do While mYn <> ""
    
17.         If mYn <> ThisWorkbook.Name Then
    
18.             Set wb = GetObject(mYp & mYn)   ' Set wb = Workbooks.Open(mYp & mYn)
    
19.             bm = Mid(wb.Name, 1, InStrRev(wb.Name, ".") - 1)  ' 表名，不带尾缀
    
20.             For Each sht In wb.Sheets
    
21.                 If sht.Name = sName Then  ' 如果指定工作表存在
    
22.                     With sht
    
23.                         mRow = .Cells(.Rows.Count, 1).End(3).Row  ' 打开的表，A列最大行号
    
24.                         arr = .Range(.Cells(7, 1), .Cells(mRow - 1, mCol)).Value  ' 打开的表，赋值到数组
    
25.                     End With
    
26.                     For i = 1 To UBound(arr)
    
27.                         If arr(i, 1) <> "" Then
    
28.                             mStr = arr(i, 1) & "," & bm
    
29.                             If Not d.Exists(mStr) Then d(mStr) = Val(arr(i, mCol)) Else d(mStr) = d(mStr) + Val(arr(i, mCol))
    
30.                         End If
    
31.                     Next
    
32.                 End If
    
33.             Next
    
34.             wb.Close False
    
35.         End If
    
36.         mYn = Dir()
    
37.     Loop
    
38.     With TheBook.Worksheets("模板")
    
39.         .Activate
    
40.         mRow = .Cells(.Rows.Count, 1).End(3).Row
    
41.         .Range("B2:F" & mRow).ClearContents
    
42.         arr = .Range("A1:F" & mRow).Value
    
43.         For i = 2 To UBound(arr)
    
44.             For j = 2 To UBound(arr, 2)
    
45.                 If arr(i, 1) <> "" Then If d.Exists(arr(i, 1) & "," & arr(1, j)) Then arr(i, j) = d(arr(i, 1) & "," & arr(1, j))
    
46.             Next
    
47.         Next
    
48.         .Range("A1:F" & mRow).Value = arr
    
49.     End With
    
50.     Set d = Nothing: Set TheSheet = Nothing: Set TheBook = Nothing: Set wb = Nothing
    
51.     Application.DisplayAlerts = True: Application.ScreenUpdating = True
    
52.     MsgBox "操作已完成，用时约：" & Format(Timer - T1, "0.0") & " 秒. ", 64 + 0, "提醒"
    
53. End Sub

复制代码