1.  轨迹变色 by:Nothwolves

‘轨迹变色.xls
‘http://club.excelhome.net/dispbbs.asp?boardID=2&ID=237019&page=1&px=0
Sub Macro4()
'by:northwolves
'2007/4/28
 
Application.ScreenUpdating = False
Dim n As Long
n = [d65536].End(xlUp).Row
[k2].FormulaArray = "=IF(COUNTIF(R1C4:R[-1]C4,RC6),MAX((R1C4:R[-1]C4=RC6)*ROW(R1C4:R[-1]C4)),0)"
‘从D1到当前行区域中查找当前行F列，取得最近的相等值的行数
[k2].AutoFill [k2].Resize(n - 1, 1)        ‘复制到数据最下端
[h2].Resize(n - 1, 1) = "=IF(RC11>0,RIGHT(LARGE(OFFSET(R1C4,RC[3]-1,0,1,3),1)+LARGE(OFFSET(R1C4,RC[3]-1,0,1,3),2),1),"""")"        ‘利用K列辅助列，求得两个大值相加之和的个位数
[i2].Resize(n - 1, 2) = "=IF(LEN(RC[-1]),RIGHT(RC[-1]+1),"""")"          ‘I、j列同行赋值
[h:j] = [h:j].Value          ‘用数值选择性粘贴到原位
[k2].Resize(n - 1, 1) = ""       ‘删除辅助列
[h2].Resize(n - 1, 3).Select           ‘运用条件格式公式，相同数字变红色
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF($D2:$F2,H2)>0"
Selection.FormatConditions(1).Font.ColorIndex = 3
[h1].Select
Application.ScreenUpdating = True
End Sub
 
 
Sub macro1()
'by:northwolves
'2007/4/28
Dim r As Range, i As Long, n As Long, v As Byte
n = [d65536].End(xlUp).Row
[h:j].Delete
For i = 2 To n
Set r = [d1].Resize(i - 1, 1).Find(Cells(i, 6), , , , , xlPrevious)      ‘从D1－I上一行区域中查找F列I行的值
If Not r Is Nothing Then
v = (WorksheetFunction.Large(r.Resize(1, 3), 1) + WorksheetFunction.Large(r.Resize(1, 3), 2)) Mod 10  ‘三个数中两个大的相加，取个位数
For j = 0 To 2
Cells(i, 8 + j) = (v + j) Mod 10      ‘H、I、J三列赋值
If WorksheetFunction.CountIf(Cells(i, 4).Resize(1, 3), Cells(i, 8 + j)) > 0 Then Cells(i, 8 + j).Font.Color = vbRed         ‘如果在DEF列中有相同的数，字体变红色
Next
End If
Next
[h1].Resize(n, 3).Borders.LineStyle = 1       ‘加边框
MsgBox "ok"
End Sub