根据科目号依次取值。

hlly888

按科目提取金额.rar (14.07 KB, 下载次数: 9)

2014-4-23 21:23 上传

点击文件名下载附件

chxw68

修改好了。

LMY123

字典与字典嵌套

lsdongjh

1. Sub Test()
   
2.     Dim SH As Worksheet
   
3.     Dim lngRow As Long, lngCol As Long, arr As Variant
   
4.     Dim objDic As Object, strKey As String, strItem As String
   
5.     Dim strSplit() As String, lngI As Long
   
6.    
   
7.     Set SH = Sheets("Sheet1")
   
8.     lngRow = SH.Range("F" & Rows.Count).End(xlUp).Row
   
9.     arr = SH.Range("F3:G" & lngRow)
   
10.    
    
11.     Set objDic = CreateObject("Scripting.Dictionary")
    
12.    
    
13.     '将数据装入字典
    
14.     For lngRow = LBound(arr) To UBound(arr)
    
15.         strKey = arr(lngRow, 1)
    
16.         strItem = arr(lngRow, 2)
    
17.         objDic(strKey) = objDic(strKey) & "," & strItem
    
18.     Next
    
19.    
    
20.     '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
21.     '按列显示：一个科目一列
    
22.     arr = SH.Range("A2:D2")
    
23.     For lngCol = 2 To UBound(arr, 2)
    
24.         strKey = arr(1, lngCol)
    
25.         strItem = objDic(strKey)
    
26.         strItem = Mid(strItem, 2)
    
27.         strSplit = Split(strItem, ",")
    
28.         SH.Cells(3, lngCol).Resize(UBound(strSplit) + 1, 1) = Application.WorksheetFunction.Transpose(strSplit)
    
29.     Next
    
30.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
31.    
    
32.     '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
33.     '按行显示：一个科目一行
    
34.     arr = SH.Range("B21:C29")
    
35.     For lngRow = 1 To UBound(arr)
    
36.         strKey = arr(lngRow, 1)
    
37.         strItem = objDic(strKey)
    
38.         strItem = Mid(strItem, 2)
    
39.         strSplit = Split(strItem, ",")
    
40.         arr(lngRow, 2) = strSplit(0)
    
41.         
    
42.         strSplit(0) = ""
    
43.         strItem = Join(strSplit, ",")
    
44.         objDic(strKey) = strItem
    
45.     Next
    
46.     SH.Range("B21:C29") = arr
    
47.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
48. End Sub
    

复制代码