Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

66447 / 76734

←次へ　｜　前へ→


	【14850】Re:コードの重複チェック　訂正　大きく

ichinose - 04/6/8(火) 20:59 -


	引用なし

	パスワード

前のコードではダメです。
訂正します。
'=====================================================
Sub test()
　 Dim rng As Range
　 Dim wk As Variant
　 Dim ans As Collection
　 Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp))
　 If rng.Row > 1 And rng.Count > 1 Then
　　　ReDim wk(1 To rng.Count)
　　　With rng
　　　　 wk = Evaluate("=transpose(if(countif(" & .Address & "," & .Address & ")>1,text(" & .Address _
　　　　　　　　& ",""0000""),""" & Chr(1) & """))")
　　　　 wk1 = Filter(wk, Chr(1), False)
　　　　 End With
　　　Set ans = mk_unique_collection(wk1)
　　　For idx = 1 To ans.Count
　　　　 mes = mes & ans(idx) & vbLf
　　　　 Next
　　　MsgBox mes
　　　End If
End Sub
'========================================================
Function mk_unique_collection(myarray)
　 Dim myclct As New Collection
　 On Error Resume Next
　 For idx = LBound(myarray) To UBound(myarray)
　　　myclct.Add myarray(idx), myarray(idx)
　　　Next
　 Set mk_unique_collection = myclct
　 Set myclct = Nothing
　 On Error GoTo 0
End Function

>まっ、参考程度に確認して下さい。

1 hits

▼

【14823】コードの重複チェック ikke 04/6/8(火) 16:37