本帖最后由 mmc998 于 2015-1-14 06:34 编辑
Sub test()
Dim arr, i%, j%
arr = Sheet1.Range("a1:ap" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
For i = 3 To UBound(arr)
For j = 8 To UBound(arr, 2)
arr(i, j) = IIf(arr(i, 1) = arr(1, j) Or arr(i, 2) = arr(1, j) Or arr(i, 3) = arr(1, j) Or arr(i, 4) = arr(1, j) Or arr(i, 5) = arr(1, j), 0, arr(i - 1, j) + 1)
Next
Next
With Sheet2
.UsedRange.ClearContents
.[a1].Resize(i - 1, j - 1) = arr
End With
MsgBox "处理完毕!", , "提示"
End Sub
Option Explicit
Sub test()
Dim arr, i, j, k
Sheets("Sheet2").Select
arr = Range("a1:ap" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 3 To UBound(arr)
For j = 8 To UBound(arr, 2)
'arr(i, j) = IIf(arr(i, 1) = arr(1, j) Or arr(i, 2) = arr(1, j) Or arr(i, 3) = arr(1, j) Or arr(i, 4) = arr(1, j) Or arr(i, 5) = arr(1, j), 0, arr(i - 1, j) + 1)
'1)先假设条件不等于,即arr(i,j)=arr(i,j)
arr(i, j) = arr(i - 1, j) + 1
'2)判断arr(i,j)与本行前6列各值是否相等
For k = 2 To 6
If arr(1, j) = arr(i, k) Then
'3)一旦相等,arr(i,j)=0,结束判断
arr(i, j) = 0
Exit For
End If
Next k
Next j
Next i
With Sheets("Sheet2")
' .UsedRange.ClearContents
.[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
End With
MsgBox "处理完毕!", , "提示"
End Sub
Book大遗3.rar
(222.81 KB, 下载次数: 13)
|