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

乐开花36

收录了每天的数据(从右到左共三天),四列内容各自排序后,提取前十个(由大到小降序排列)对应名称列的内容,加上当天日期跨表存入单元格内保存,送花以表谢意 从大到小提取对应列内容.zip (42.2 KB, 下载次数: 5)

2018-7-31 20:59 上传

点击文件名下载附件

xiangbaoan

……………………………………

1. Option Explicit
   
2. Sub t()
   
3. Application.ScreenUpdating = False
   
4. Dim ar, br, cr(2, 3), a, b, i%, c%, st$
   
5. a = Array(1, 27, 53)
   
6. b = Array(3, 4, 5, 6)
   
7. With Sheets("收盘数据")
   
8. For i = 0 To UBound(a)
   
9.     ar = .Cells(1, a(i)).CurrentRegion
   
10.     For c = 0 To UBound(b)
    
11.         .Cells(1, a(i)).CurrentRegion.Offset(1).Sort .Cells(2, b(c) + i * 26), 2, Header:=1
    
12.         br = Application.Transpose(.Cells(3, 2 + i * 26).Resize(10))
    
13.         st = .Cells(1, 1 + i * 26) & "," & Join(br, ",")
    
14.         cr(2 - i, c) = st
    
15.     Next
    
16.     .Cells(1, a(i)).CurrentRegion = ar
    
17. Next
    
18. End With
    
19. Application.ScreenUpdating = True
    
20. With Sheets("查看").[b3]
    
21.     .Resize(88, 4) = ""
    
22.     .Resize(3, 4) = cr
    
23. End With
    
24. End Sub

复制代码

weisilisid

这个不难，就排序后，用数组取前10,搜一下论坛内很多

乐开花36

xiangbaoan 发表于 2018-8-1 10:01
……………………………………

收盘数据每天更新,,怎样改一下,在查看中追加保存?新的追加,已有的就不要动了

xiangbaoan

乐开花36 发表于 2018-8-1 17:09
收盘数据每天更新,,怎样改一下,在查看中追加保存?新的追加,已有的就不要动了

'这样试试
Option Explicit
Sub t()
Application.ScreenUpdating = False
Dim ar, br, cr(2, 3), a, b, i%, c%, st$
a = Array(1, 27, 53)
b = Array(3, 4, 5, 6)
With Sheets("收盘数据")
For i = 0 To UBound(a)
    ar = .Cells(1, a(i)).CurrentRegion
    For c = 0 To UBound(b)
        .Cells(1, a(i)).CurrentRegion.Offset(1).Sort .Cells(2, b(c) + i * 26), 2, Header:=1
        br = Application.Transpose(.Cells(3, 2 + i * 26).Resize(10))
        st = .Cells(1, 1 + i * 26) & "," & Join(br, ",")
        cr(2 - i, c) = st
    Next
    .Cells(1, a(i)).CurrentRegion = ar
Next
End With
Sheets("查看").Cells(Rows.Count, 2).End(xlUp).Offset(1).Resize(3, 4) = cr
Application.ScreenUpdating = True
End Sub

乐开花36

xiangbaoan 发表于 2018-8-1 17:30
'这样试试
Option Explicit
Sub t()

就是这个意思,能否加个判断?查看工作表已经存在备份了,就不要重复,没有就追加下去哦,花已送,先谢谢啦

xiangbaoan

乐开花36 发表于 2018-8-1 18:01
就是这个意思,能否加个判断?查看工作表已经存在备份了,就不要重复,没有就追加下去哦,花已送,先谢谢啦

Option Explicit
Sub t()
If Trim(Split(Sheets("查看").Cells(Rows.Count, 2).End(xlUp), ",")(0)) = Trim(Sheets("收盘数据").[a1]) Then
MsgBox "已备份，不重复操作！": Exit Sub
Else
Application.ScreenUpdating = False
Dim ar, br, cr(2, 3), a, b, i%, c%, st$
a = Array(1, 27, 53)
b = Array(3, 4, 5, 6)
With Sheets("收盘数据")
For i = 0 To UBound(a)
    ar = .Cells(1, a(i)).CurrentRegion
    For c = 0 To UBound(b)
        .Cells(1, a(i)).CurrentRegion.Offset(1).Sort .Cells(2, b(c) + i * 26), 2, Header:=1
        br = Application.Transpose(.Cells(3, 2 + i * 26).Resize(10))
        st = .Cells(1, 1 + i * 26) & "," & Join(br, ",")
        cr(2 - i, c) = st
    Next
    .Cells(1, a(i)).CurrentRegion = ar
Next
End With
Sheets("查看").Cells(Rows.Count, 2).End(xlUp).Offset(1).Resize(3, 4) = cr
ThisWorkbook.Save
Application.ScreenUpdating = True
MsgBox "ok!"
End If
End Sub
'客气了，你看是不是这样?

乐开花36

xiangbaoan 发表于 2018-8-1 18:34
Option Explicit
Sub t()
If Trim(Split(Sheets("查看").Cells(Rows.Count, 2).End(xlUp), ",")(0)) =  ...

收盘数据更新每天是从左到右移动考贝,RANGE("A:Z")区域是最新,这样还是有重复的，最好能查找判断，没有就更新，有了就不了，，

xiangbaoan

乐开花36 发表于 2018-8-1 18:55
收盘数据更新每天是从左到右移动考贝,RANGE("A:Z")区域是最新,这样还是有重复的，最好能查找判断，没有就 ...

Option Explicit
Sub t()'我想你是这个意思
Application.ScreenUpdating = False
Dim lr&, ar, br, cr(2, 3), a, b, d As Object, i%, c%, st$, ymd$
Set d = CreateObject("scripting.dictionary")
With Sheets("查看")
    lr = .Cells(Rows.Count, 2).End(xlUp).Row
    If lr > 2 Then
        ar = .Range("b3:b" & lr)
        For i = 1 To UBound(ar)
            If Len(ar(i, 1)) Then: ymd = Trim(Split(ar(i, 1), ",")(0)): d(ymd) = ""
        Next
    End If
End With
a = Array(1, 27, 53)
b = Array(3, 4, 5, 6)
With Sheets("收盘数据")
For i = UBound(a) To 0 Step -1
    ymd = Trim(.Cells(1, a(i)))
    If Not d.exists(ymd) Then
        ar = .Cells(1, a(i)).CurrentRegion
        For c = 0 To UBound(b)
            .Cells(1, a(i)).CurrentRegion.Offset(1).Sort .Cells(2, b(c) + i * 26), 2, Header:=1
            br = Application.Transpose(.Cells(3, 2 + i * 26).Resize(10))
            st = .Cells(1, 1 + i * 26) & "," & Join(br, ",")
            cr(0, c) = st
        Next
        .Cells(1, a(i)).CurrentRegion = ar
        Sheets("查看").Cells(Rows.Count, 2).End(xlUp).Offset(1).Resize(1, 4) = cr
    End If
Next
End With
Set d = Nothing
Application.ScreenUpdating = True
End Sub

乐开花36

xiangbaoan 发表于 2018-8-2 07:19
Option Explicit
Sub t()'我想你是这个意思
Application.ScreenUpdating = False

很棒，是这个效果哦，按个股代码检索、提取保存，怎样改？ 个股信息提取保存.zip (37.82 KB, 下载次数: 1)

2018-8-2 17:27 上传

点击文件名下载附件