請問有朋友可以幫我解答VBA的問題嗎?

Question

請問，下列程式，因為用EXCEL的格式化條件做不出來，所以我需要用VBA完成，麻煩會VBA或EXCEL的朋友指導一下，謝謝。
1.首先我要搜尋11，22，33，44，55，66，有相同分數者把它用顏色加以註記。
2.只要有分數(顏色)有2個以上相同時，把人名用顏色註記。
3.把人名有顏色註記的，國文以後到軍訓的資料貼到其他欄(比如張三，小伍，老六這3個人國文~軍訓間的資料，我要複製到名次之後的欄位)。 　 國文 英文 數學 理化 歷史 軍訓 總分 名次 張三 11 22 33 44 55 66 231 2 李四 31 20 30 40 50 55 226 3 小伍 12 55 34 45 22 67 235 1 老六 11 5 33 12 66 44 171 4

牧童大大，我的信箱:[e-mail]，麻煩您了。

W.J.S大大謝謝您的檔案，不過請問一下，如果李四的資料不要複製過去(因為他沒有2各相同分數以上)，我該怎麼改呢?

Answer 1

'蒙您抬愛,我對Excel不很熟,您試試看吧!!
'為避免被知識+吃掉一些符號我把檔案(2000的版本)放置於此:點我下載(只能放7天)
Private Sub CommandButton1_Click()
Dim R&, C&, N!, xColor, M%(6)

xColor = Array(15, 3, 33, 40, 6, 43, 7)'定義顏色值
R = 2
'計算到姓名欄位等於空值時就停止
Do Until Range("A" & R) = ""
For C = 2 To 7
N = Val(Cells(R, C))
If N = Int(N) And N > 0 And N Mod 11 = 0 Then M(N / 11) = M(N / 11) + 1
Next
R = R + 1
Loop

Dim A%, B As Boolean

For R = 2 To R - 1
A = 0: B = False
For C = 2 To 7
N = Val(Cells(R, C))
If N = Int(N) And N > 0 And N Mod 11 = 0 Then
If M(N / 11) > 1 Then Cells(R, C).Interior.ColorIndex = xColor(N / 11): B = True: A = A + 1
End If
Next
If A > 1 Then Cells(R, 1).Interior.ColorIndex = xColor(0)
If B Then Range(Cells(R, 10), Cells(R, 15)).Value = Range(Cells(R, 2), Cells(R, 7)).Value
Next
End Sub

2006-12-14 01:19:13 補充：
不讓我補充了,再下載1次吧

2006-12-14 01:20:36 補充：
"http://www.yousendit.com/transfer.php?action=check_download&ufid=0EBF0B3000BF2AE0&key=bbddd18d1e89565d9c0bc5ebed8d36cad89c1d6e

2006-12-14 17:18:11 補充：
發現Bug,請重新下載XD
"

2006-12-14 17:18:33 補充：
"

2006-12-14 17:21:24 補充：
算了知識加＋老是沒辦法顯示網址,寄給你好了

Answer 2

使用方法為必須先選擇你的資料範圍 (如上例為 A1:I5)，然後再執行下列巨集即可。程式假設最上面與最左邊為姓名、科目標題列，最右邊兩列為總分、名次，所以都不列入比較。註解我都寫在程式中，有不清楚的地方再討論
Sub Macro1()
'
' Macro1 Macro
' Johnny 在 2006/12/13 錄製的巨集
'
' 快速鍵: Ctrl+a
'

If Selection.Count = 1 Then
MsgBox "請選擇所有資料範圍後，再執行巨集"
Exit Sub
End If

DataRows = Selection.Rows.Count - 1
DataCols = Selection.Columns.Count - 3
DataCells = DataRows * DataCols
CellColor = 0

For i = 0 To DataCells - 2 '原始資料
r1 = i \ DataCols + 2
c1 = i Mod DataCols + 2

For j = i + 1 To DataCells - 1 '比對資料
r2 = j \ DataCols + 2
c2 = j Mod DataCols + 2


2006-12-13 17:00:03 補充：
If Selection.Cells(r1, c1) = Selection.Cells(r2, c2) Then
If (Selection.Cells(r1, c1).Interior.ColorIndex = -4142) Then '尚未設定顏色
Selection.Cells(r1, c1).Interior.ColorIndex = CellColor 3

2006-12-13 17:01:10 補充：
Selection.Cells(r2, c2).Interior.ColorIndex = CellColor 3
CellColor = (CellColor 1) Mod 16
Else
Selection.Cells(r2, c2).Interior.ColorIndex = Selection.Cells(r1, c1).Interior.ColorIndex
End If
End If

2006-12-13 17:01:44 補充：
Next j
Next i

For i = 2 To DataRows 1
ColorNumbers = 0
For j = 2 To DataCols 1
If (Selection.Cells(i, j).Interior.ColorIndex <> -4142) Then
ColorNumbers = ColorNumbers 1
End If

2006-12-13 17:02:17 補充：
Next j

If ColorNumbers >= 2 Then
Selection.Cells(i, 1).Interior.ColorIndex = 12

2006-12-13 17:02:25 補充：
For j = 2 To DataCols 1 '複製資料
Selection.Cells(i, j DataCols 2) = Selection.Cells(i, j)
Next j
End If
Next i
End Sub

2006-12-13 17:04:44 補充：
字數限制真是討厭，而且補充的內容加號都不見了 (在 For 後面)，若需要 Excel 檔案，再麻煩你留 e-mail，我再寄給你

2006-12-14 09:27:13 補充：
沒想到用陣列做程式會精簡多了，而且顏色我也是遞增而已，厲害