怎样列内数据降序排列提出前十位对应列内容跨表保存到单元格内

xiangbaoan

乐开花36 发表于 2018-8-2 17:28
很棒，是这个效果哦，按个股代码检索、提取保存，怎样改？

你的问题还真不少，自行测试…………

1. Sub tt() '个股信息提取
   
2. Application.ScreenUpdating = False
   
3. Dim lr&, ar, br(), a, b, d As Object, i%, c%, r&, cd$, st$, ymd$, k&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. With Sheets("查看")
   
6.     cd = .[b3]
   
7.     lr = .Cells(Rows.Count, 2).End(xlUp).Row
   
8.     If lr > 3 Then
   
9.         If lr = 4 Then
   
10.             d(Trim(cd & Split(.[b4], ",")(0))) = ""
    
11.         Else
    
12.             ar = .Range("b4:b" & lr)
    
13.             For i = 1 To UBound(ar)
    
14.                 If Len(ar(i, 1)) Then: ymd = Trim(Split(ar(i, 1), ",")(0)): d(cd & ymd) = ""
    
15.             Next
    
16.         End If
    
17.     End If
    
18. End With
    
19. a = Array(1, 27, 53)
    
20. b = Array(2, 3, 5, 6)
    
21. With Sheets("收盘数据")
    
22.     For i = UBound(a) To 0 Step -1
    
23.         ymd = Trim(.Cells(1, a(i)))
    
24.         If Not d.exists(cd & ymd) Then
    
25.             ar = .Cells(1, a(i)).CurrentRegion.Resize(, 6)
    
26.             For r = 3 To UBound(ar)
    
27.                 st = ""
    
28.                 If ar(r, 1) = cd Then
    
29.                     k = k + 1
    
30.                     ReDim Preserve br(1 To k)
    
31.                     For c = 0 To UBound(b)
    
32.                         st = st & "," & ar(r, b(c))
    
33.                     Next
    
34.                     br(k) = ymd & st
    
35.                 End If
    
36.             Next
    
37.         End If
    
38.     Next
    
39. End With
    
40. If k Then Sheets("查看").Cells(Rows.Count, 2).End(xlUp).Offset(1).Resize(k) = WorksheetFunction.Transpose(br)
    
41. Set d = Nothing
    
42. Application.ScreenUpdating = True
    
43. End Sub
    

复制代码

xiangbaoan

加了个循环，把一行4个代码号的都一次性提取了，可能这是你需要的。