请教高手：怎样用VBA，着色？谢谢

wjk7222

     怎样用VBA， 给 每组中 成绩中相同的分数 着色 （填充红色或绿色 等随机的颜色）。（如果出现重复的分数 填充不同的颜色不好搞，那就只填一种颜色，也行）
       成绩单 每6个连续编号作为1组， 即 编号1-6号作为1 组，7-12号作为1组，13-18号作为1组，以此类推。怎样用 VBA 给 每组中 成绩中相同的分数 着色 （填充红色或绿色 等颜色）（也就是把每组中重复出现两次及两次以上 的分数，填充为红色或绿色 等随机的颜色）？
       比如：编号1-6 这组中，分数 55 出现重复2次， 分数 92 出现重复4次，则把 55、92 填充为红色 或 绿色 等随机的颜色。
     （难点：样例只有18个人的成绩，实际成绩单有一千多人。） （如果出现重复的分数 填充不同的颜色不好搞，那就只填一种颜色，也行）

zpy2

with a as (select 组,数量,count(*) 次数,case when count(*)>1 then '<span style="background-color:yellow">'||数量||'green</span>' else 数量 end as 分数 from 学生成绩标示一维明细表 group by 组,数量),b as (select c.rowid,* from 学生成绩标示一维明细表 c join a using(组,数量)) select rowid,组,编号||姓名 姓名2,属性 列标签,分数 数据 from b order by 组

2维转1维吧

select 姓名,group_concat(distinct(case when 列标签='化学' then 数据 else null end)) as '化学',group_concat(distinct(case when 列标签='地理' then 数据 else null end)) as '地理',group_concat(distinct(case when 列标签='政治' then 数据 else null end)) as '政治',group_concat(distinct(case when 列标签='数
学' then 数据 else null end)) as '数学',group_concat(distinct(case when 列标签='物理' then 数据 else null end)) as '物理',group_concat(distinct(case when 列标签='生物' then 数据 else null end)) as '生
物',group_concat(distinct(case when 列标签='英语' then 数据 else null end)) as '英语',group_concat(distinct(case when 列标签='语文' then 数据 else null end)) as '语文' from (select 姓名,列标签,group_concat(数据,'/') 数据 from 人员名单一维表 group by 姓名,列标签) group by 姓名
再转2维


大概是这个思路，感觉还是比较绕，特别是 着色。。。。

wjk7222

谢谢高手大侠！假如颜色 是随机的，是不是更简单些？能否在样例上示范一下？谢谢！

无烟晴雨

使用条件格式不是更简单一点啊，没明白你的特殊需求

无烟晴雨

1. Sub zhaose()
   
2. Dim arr, Temparr, Rg As Range, myaddress, Allrow
   
3. ActiveSheet.Range("A1:J500").Interior.ColorIndex = xlNone
   
4. Allrow = ActiveSheet.Range("B1").End(xlDown).Row
   
5. arr = ActiveSheet.Range("$C$2:$J$" & Allrow)
   
6. 
   
7. For i = 1 To UBound(arr, 2) '2是列
   
8.     ReDim Temparr(1 To UBound(arr, 1))
   
9.     For j = 1 To UBound(arr, 1) '1是行
   
10.         Temparr(j) = arr(j, i)
    
11.     Next
    
12.     For k = 1 To UBound(Temparr, 1)
    
13.         For m = 1 To UBound(arr, 1)
    
14.             If arr(k, i) = Temparr(m) And m <> k Then
    
15.             '无需延时时删掉下面这1句
    
16.                 delay 0.005
    
17.                 ActiveSheet.Cells(k + 1, i + 2).Interior.ColorIndex = 3
    
18.             End If
    
19.         Next
    
20.     Next
    
21. Next
    
22. 
    
23. End Sub
    
24. Public Function delay(t As Single)
    
25. Dim T1 As Single
    
26. T1 = Timer
    
27. Do
    
28. DoEvents
    
29. Loop While Timer - T1 < t
    
30. End Function

复制代码