Excel VBA質問箱 IV

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

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


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

57266 / 76732

←次へ　｜　前へ→


	【24203】Re:データチェックおよび抽出について

ウッシ - 05/4/15(金) 13:46 -


	引用なし

	パスワード

こんにちは

「数値」のケースは考慮してなかったです。
こちらで試して下さい。

Sub データ照合1()
'「項目1」のデータが「AAA」、「項目2」のデータが「1」の場合、
'「項目2」のセルを赤く表示
　　Const 項目1_Dat As Variant = "AAA"
　　Const 項目2_Dat As Variant = 1
　　
　　Dim 項目1_DatC As Variant
　　Dim 項目2_DatC As Variant
　　Dim 項目1_Col As Variant
　　Dim 項目2_Col As Variant
　　Dim g　　 As Long
　　Dim r　　 As Range
　　Dim newBk As Workbook
　　
　　With ActiveSheet
　　　　項目1_Col = Application.Match("項目1", .Rows(1), 0)
　　　　項目2_Col = Application.Match("項目2", .Rows(1), 0)
　　　　If IsError(項目1_Col) Then Exit Sub
　　　　If IsError(項目2_Col) Then Exit Sub
　　　　
　　　　項目1_DatC = _
　　　　　　IIf(IsNumeric(項目1_Dat), 項目1_Dat, _
　　　　　　　　　　　　　　　Chr(34) & 項目1_Dat & Chr(34))
　　　　項目2_DatC = _
　　　　　　IIf(IsNumeric(項目2_Dat), 項目2_Dat, _
　　　　　　　　　　　　　　　Chr(34) & 項目2_Dat & Chr(34))
　　　　　　　　
　　　　　　　　
　　　　g = ActiveWindow.ActiveCell.Row
　　　　With .Range("IV" & g & ":IV" & .Range("A65536").End(xlUp).Row)
　　　　　　.FormulaR1C1 = _
　　　　　　　　"=IF(AND(RC" & 項目1_Col & "=" & 項目1_DatC & _
　　　　　　　　　　　　",RC" & 項目2_Col & "=" & 項目2_DatC & _
　　　　　　　　　　　　"),1,"""")"
　　　　　　.Value = .Value
　　　　　　On Error Resume Next
　　　　　　Set r = .SpecialCells(xlCellTypeConstants)
　　　　　　On Error GoTo 0
　　　　　　If Not r Is Nothing Then
　　　　　　　　Set newBk = Workbooks.Add
　　　　　　　　Intersect(r.EntireRow, .Parent.Columns(項目2_Col)) _
　　　　　　　　　　.Interior.ColorIndex = 3
　　　　　　　　r.EntireRow.Copy newBk.Worksheets(1).Range("A1")
　　　　　　　　newBk.SaveAs ThisWorkbook.Path & "\エラーデータ.xls"
　　　　　　End If
　　　　　　.ClearContents
　　　　End With
　　End With
End Sub

1 hits

▼

【24181】データチェックおよび抽出について KOTARO 05/4/14(木) 17:26