[已解决]找出最大行数信息放进规定的表中

zss7758258

原始数据.zip (808.68 KB, 下载次数: 35)

2015-2-2 23:58 上传

点击文件名下载附件

说明.zip (130.31 KB, 下载次数: 9)

2015-2-2 23:58 上传

点击文件名下载附件

谢谢老师们！

最佳答案

月排行榜 / 总排行榜

dsmch

2015-2-3 13:01

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, k%, zf$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets("程序结果").Range("a1").CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.     zf = Left(arr(i, 3), 1) & "," & arr(i, 4)
   
7.     If Not d.exists(zf) Then
   
8.         d(zf) = i
   
9.     Else
   
10.         If arr(i, 1) > arr(d(zf), 1) Then d(zf) = i
    
11.     End If
    
12. Next
    
13. For j = 1 To Sheets.Count
    
14.     If Sheets(j).Name <> "程序结果" Then
    
15.         gzb = Left(Sheets(j).Name, 1)
    
16.         brr = Sheets(j).Range("a1").CurrentRegion
    
17.         ReDim crr(1 To UBound(brr) - 1, 1 To 3)
    
18.         For i = 2 To UBound(brr)
    
19.             zf = gzb & "," & brr(i, 4)
    
20.             If d.exists(zf) Then
    
21.                 n = d(zf)
    
22.                 For k = 1 To 3
    
23.                     crr(i - 1, k) = arr(n, k)
    
24.                 Next
    
25.             End If
    
26.         Next
    
27.         Sheets(j).Range("a2").Resize(UBound(crr), 3) = crr
    
28.     End If
    
29. Next
    
30. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets("程序结果").Range("a1").CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.     If Not d.exists(arr(i, 4)) Then
   
7.         d(arr(i, 4)) = arr(i, 1)
   
8.     Else
   
9.         If arr(i, 1) > d(arr(i, 4)) Then d(arr(i, 4)) = arr(i, 1)
   
10.     End If
    
11. Next
    
12. For j = 1 To Sheets.Count
    
13.     If Sheets(j).Name <> "程序结果" Then
    
14.         brr = Sheets(j).Range("a1").CurrentRegion
    
15.         ReDim crr(1 To UBound(brr) - 1, 1 To 1)
    
16.         For i = 2 To UBound(brr)
    
17.             crr(i - 1, 1) = d(brr(i, 4))
    
18.         Next
    
19.         Sheets(j).Range("a2").Resize(UBound(crr)) = crr
    
20.     End If
    
21. Next
    
22. End Sub

复制代码

zss7758258

dsmch 发表于 2015-2-3 10:01

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, k%, zf$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets("程序结果").Range("a1").CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.     zf = Left(arr(i, 3), 1) & "," & arr(i, 4)
   
7.     If Not d.exists(zf) Then
   
8.         d(zf) = i
   
9.     Else
   
10.         If arr(i, 1) > arr(d(zf), 1) Then d(zf) = i
    
11.     End If
    
12. Next
    
13. For j = 1 To Sheets.Count
    
14.     If Sheets(j).Name <> "程序结果" Then
    
15.         gzb = Left(Sheets(j).Name, 1)
    
16.         brr = Sheets(j).Range("a1").CurrentRegion
    
17.         ReDim crr(1 To UBound(brr) - 1, 1 To 3)
    
18.         For i = 2 To UBound(brr)
    
19.             zf = gzb & "," & brr(i, 4)
    
20.             If d.exists(zf) Then
    
21.                 n = d(zf)
    
22.                 For k = 1 To 3
    
23.                     crr(i - 1, k) = arr(n, k)
    
24.                 Next
    
25.             End If
    
26.         Next
    
27.         Sheets(j).Range("a2").Resize(UBound(crr), 3) = crr
    
28.     End If
    
29. Next
    
30. End Sub

复制代码

zss7758258

dsmch 发表于 2015-2-3 13:01

999.zip (563.57 KB, 下载次数: 13)

2015-2-4 10:18 上传

点击文件名下载附件

老师再补充一下小问题

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, k%, zf$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets("程序结果").Range("a1").CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.     zf = Left(arr(i, 3), 1) & "," & arr(i, 4)
   
7.     If Not d.exists(zf) Then
   
8.         d(zf) = i
   
9.     Else
   
10.         If arr(i, 1) > arr(d(zf), 1) Then d(zf) = i
    
11.     End If
    
12. Next
    
13. For j = 3 To Sheets.Count
    
14.     gzb = Left(Sheets(j).Name, 1)
    
15.     brr = Sheets(j).Range("a1").CurrentRegion
    
16.     ReDim crr(1 To UBound(brr) - 1, 1 To 3)
    
17.     For i = 2 To UBound(brr)
    
18.         zf = gzb & "," & brr(i, 4)
    
19.         If d.exists(zf) Then
    
20.             n = d(zf)
    
21.             For k = 1 To 3
    
22.                 crr(i - 1, k) = arr(n, k)
    
23.             Next
    
24.         End If
    
25.     Next
    
26.     Sheets(j).Range("a2").Resize(UBound(crr), 3) = crr
    
27. Next
    
28. End Sub

复制代码

zss7758258

dsmch 发表于 2015-2-4 12:40

请问第13行
For j = 3 To Sheets.Count
表示从第三个表开始清空的意思吗？

dsmch

对的