表格遇到难题了，请教高手老师。

双眼皮lsk

表1数据如何自动生成在表2里面（本月完成和5月完成处所这两列数据需要自动生成）。

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim myPath$, myName$, Arr1(), r%, sh As Worksheet, Arr, col%
   
3.     Dim i&, Brr, nm$, d, x$, y$, j&, ks, js, yf
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Sheet3.Activate
   
7.     yf = 5: col = yf + 12
   
8.     Cells(4, col).Resize(500, 1).ClearContents
   
9.     Arr = [a1].CurrentRegion
   
10.     For i = 4 To UBound(Arr)
    
11.         If Arr(i, 1) <> "" Then
    
12.             r = r + 1
    
13.             ReDim Preserve Arr1(1 To r)
    
14.             Arr1(r) = i
    
15.         End If
    
16.     Next
    
17.     For i = 1 To r
    
18.     If i <> r Then
    
19.         js = Arr1(i + 1) - 1
    
20.     Else
    
21.         js = UBound(Arr)
    
22.     End If
    
23.     ks = Arr1(i): x = Arr(ks, 1)
    
24.     For j = ks To js
    
25.         y = Arr(j, 3)
    
26.         If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    
27.         d(x)(y) = j
    
28.     Next
    
29.     Next
    
30.     myPath = ThisWorkbook.Path & ""
    
31.     myName = "表1（完成情况）.xls"
    
32.     With GetObject(myPath & myName)
    
33.         For Each sh In .Sheets
    
34.             Brr = sh.Range("A1").CurrentRegion
    
35.             x = sh.Name
    
36.             If UBound(Brr) > 2 Then
    
37.                 For j = 3 To UBound(Brr)
    
38.                     If Brr(j, 1) <> "" Then
    
39.                     If Val(Split(Brr(j, 1), ".")(0)) = yf Then
    
40.                     y = Brr(j, 2)
    
41.                     If d.exists(x) Then
    
42.                         If d(x).exists(y) Then
    
43.                             Cells(d(x)(y), col) = Cells(d(x)(y), col) & Brr(j, 3) & " "
    
44.                         End If
    
45.                     End If
    
46.                     End If
    
47.                     End If
    
48.                 Next
    
49.             End If
    
50.         Next
    
51.         .Close False
    
52.     End With
    
53.     Arr = [a1].CurrentRegion
    
54.     For i = 4 To UBound(Arr)
    
55.         If Arr(i, col) <> "" Then Cells(i, col) = Arr(i, col) & " 共计" & Arr(i, 6) & Arr(i, 4)
    
56.     Next
    
57.     Application.ScreenUpdating = True
    
58.     MsgBox "OK"
    
59. End Sub
    
60. 
    

复制代码

蓝桥玄霜

请见附件。

双眼皮lsk

谢谢老师，老师的代码真的很棒，就是“本月完成F列”不会自动生成，我再想想办法。{:soso_e179:}。

LMY123

d(x)(y) = j