Excel VBA質問箱 IV

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

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


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

57232 / 76732

←次へ　｜　前へ→


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

ウッシ - 05/4/16(土) 15:52 -


	引用なし

	パスワード

こんにちは

コメントアウトするのは「'」のついた4箇所です。

>>'　　Dim newBk As Workbook
>
>　　　　　　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

コードを読んで意味を考えるクセを付けて下さい。

Sub データ照合1()
'「項目1」のデータが「AAA」、「項目2」のデータが「BBB」の場合、
'「項目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
　　Dim s　　　　 As Range
　　Dim 転記_Sh　 As Worksheet
　　Dim 処理_Sh　 As Worksheet
　　
　　Set 処理_Sh = ActiveSheet
　　
　　On Error Resume Next
　　Set 転記_Sh = Worksheets("転記")
　　If 転記_Sh Is Nothing Then
　　　　Set 転記_Sh = Worksheets.Add(, Worksheets(Worksheets.Count))
　　　　転記_Sh.Name = "転記"
　　End If
　　On Error GoTo 0
　　
　　With 処理_Sh
　　　　.Select
　　　　項目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
　　　　　　　　　　For Each s In r
　　　　　　　　　　　　s.EntireRow.Copy 転記_Sh.Cells(s.Row, 1)
　　　　　　　　　　Next
'　　　　　　　　　　r.EntireRow.Copy newBk.Worksheets(1).Range("A1")
'　　　　　　　　newBk.SaveAs ThisWorkbook.Path & "\エラーデータ.xls"
　　　　　　End If
　　　　　　.ClearContents
　　　　End With
　　End With
End Sub

Sub 転記_Sh_空白行削除()
　　Dim 転記_Sh　 As Worksheet
　　
　　Set 転記_Sh = Worksheets("転記")
　　With 転記_Sh.UsedRange
　　　　.Sort .Range("IV1"), xlDescending, header:=xlNo
　　　　.Columns(256).ClearContents
　　End With
End Sub

「Sub 転記_Sh_空白行削除()」はチェックが全て終了したら実行して下さい。

8 hits

▼

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