用VBA把每列前5大数的单元格填充为红色

laoau138

用VBA把每列前5大数的单元格填充为红色

today0427

请查看

1. Sub today() '提取前五大
   
2.     Dim arr, brr(), crr(), i&, j&, k&, cf, c&, n&
   
3.     arr = Intersect(Sheets("Sheet1").[e410].CurrentRegion, Sheets("Sheet1").[e410].CurrentRegion.Offset(0, 1))
   
4.     ReDim brr(1 To 70, 1 To UBound(arr, 2))
   
5.     For i = 1 To UBound(arr)
   
6.         For j = 1 To UBound(arr, 2)
   
7.             brr(arr(i, j), j) = brr(arr(i, j), j) & i & ","
   
8.         Next
   
9.     Next
   
10.    
    
11.     ReDim crr(1 To 10, 1 To UBound(arr, 2))
    
12.     For j = 1 To UBound(brr, 2)
    
13.         i = 70
    
14.         Do While n < 5
    
15.             If brr(i, j) <> "" Then
    
16.                 If InStr(Left(brr(i, j), Len(brr(i, j)) - 1), ",") Then
    
17.                     cf = Split(Left(brr(i, j), Len(brr(i, j)) - 1), ",")
    
18.                     For c = 0 To UBound(cf)
    
19.                         n = n + 1: crr(n, j) = cf(c) - 1
    
20.                     Next
    
21.                 Else: n = n + 1: crr(n, j) = Left(brr(i, j), Len(brr(i, j)) - 1) - 1
    
22.                 End If
    
23.             End If
    
24.             i = i - 1
    
25.         Loop
    
26.         n = 0
    
27.     Next
    
28. 
    
29.     For i = 1 To UBound(crr)
    
30.         For j = 1 To UBound(crr, 2)
    
31.             If crr(i, j) <> "" Then
    
32.                 Sheets("Sheet1").Cells(410 + crr(i, j), 4 + j).Interior.ColorIndex = Rnd * 6 + 2
    
33.             End If
    
34.         Next
    
35.     Next
    
36.    Sheets("Sheet1").[e422].Resize(20, j).ClearContents
    
37.    Sheets("Sheet1").[e422].Resize(10, j - 1) = crr
    
38. End Sub

复制代码

laoau138

today0427 发表于 2016-10-4 23:13
请查看

色彩变幻好精彩啊

today0427

为了临睡前你给我的这个最佳，我也得给你个彩色的梦啊！

grf1973

today0427 发表于 2016-10-4 23:32
为了临睡前你给我的这个最佳，我也得给你个彩色的梦啊！

1. 换个思路呗。

复制代码

grf1973

today0427 发表于 2016-10-4 23:32
为了临睡前你给我的这个最佳，我也得给你个彩色的梦啊！

1. Sub grf() '提取前五大
   
2.     Dim arr, i&, j&, large5%, n%, xRng$
   
3.     arr = [e410].CurrentRegion
   
4.     [e410].CurrentRegion.Interior.ColorIndex = 0
   
5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For j = 2 To UBound(arr, 2)
   
7.         crr = Application.Index(arr, , j)
   
8.         large5 = Application.WorksheetFunction.Large(crr, 5)  '第五大数的大小
   
9.         n = 0
   
10.         For i = 1 To UBound(arr)
    
11.             If arr(i, j) >= lg5 Then
    
12.                 n = n + 1
    
13.                 brr(n, j) = i - 1
    
14.                 xRng = xRng & "," & [d410].Offset(i - 1, j - 1).Address(0, 0)      'xrng为所有符合条件的地址
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     xRng = Mid(xRng, 2)
    
19.     [d422].Offset(UBound(arr) + 2).Resize(UBound(brr), UBound(brr, 2)) = brr
    
20.     Range(xRng).Interior.ColorIndex = 3   '标红
    
21. End Sub
    

复制代码

laoau138

grf1973 发表于 2016-10-7 20:04

VBA计算一行同时出现2个数的遗漏


http://www.excelpx.com/thread-424909-1-1.html

laoau138

today0427 发表于 2016-10-4 23:13
请查看

today 来啊

VBA计算一行同时出现2个数的遗漏

http://www.excelpx.com/thread-424909-1-1.html