Excel VBA質問箱 IV

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

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


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

57279 / 76732

←次へ　｜　前へ→


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

ウッシ - 05/4/15(金) 0:19 -


	引用なし

	パスワード

こんばんは

データ照合1、2です。
これを参考に、3～5はご自分で考えてみて下さい。

Sub データ照合1()
'「項目1」のデータが「AAA」、「項目2」のデータが「BBB」の場合、
'「項目2」のセルを赤く表示
　　Const 項目1_Dat As Variant = "AAA"
　　Const 項目2_Dat As Variant = "BBB"
　　
　　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
　　　　
　　　　g = ActiveWindow.ActiveCell.Row
　　　　With .Range("IV" & g & ":IV" & .Range("A65536").End(xlUp).Row)
　　　　　　.FormulaR1C1 = _
　　　　　　　　"=IF(AND(RC" & 項目1_Col & "=""" & 項目1_Dat & _
　　　　　　　　　　　　""",RC" & 項目2_Col & "=""" & 項目2_Dat & _
　　　　　　　　　　　　"""),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

Sub データ照合2()
'「項目1」のデータが「AAA」、「項目2」のデータが「BBB」または
'「CCC」の場合、「項目2」のセルを赤く表示
　　Const 項目1_Dat　As Variant = "AAA"
　　Const 項目2_Dat1 As Variant = "BBB"
　　Const 項目2_Dat2 As Variant = "CCC"
　　
　　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
　　　　
　　　　g = ActiveWindow.ActiveCell.Row
　　　　With .Range("IV" & g & ":IV" & .Range("A65536").End(xlUp).Row)
　　　　　　.FormulaR1C1 = _
　　　　　　　　"=IF(AND(RC" & 項目1_Col & "=""" & 項目1_Dat & _
　　　　　　　　　　　　""",OR(RC" & 項目2_Col & "=""" & 項目2_Dat1 & _
　　　　　　　　　　　　""",RC" & 項目2_Col & "=""" & 項目2_Dat2 & _
　　　　　　　　　　　　""")),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

0 hits

▼

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