Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
10014 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【24181】データチェックおよび抽出について KOTARO 05/4/14(木) 17:26 質問[未読]
【24186】Re:データチェックおよび抽出について ponpon 05/4/14(木) 21:40 発言[未読]
【24188】Re:データチェックおよび抽出について KOTARO 05/4/14(木) 23:23 発言[未読]
【24190】Re:データチェックおよび抽出について ウッシ 05/4/15(金) 0:19 回答[未読]
【24191】Re:データチェックおよび抽出について KOTARO 05/4/15(金) 0:30 お礼[未読]
【24197】Re:データチェックおよび抽出について KOTARO 05/4/15(金) 11:17 発言[未読]
【24198】Re:データチェックおよび抽出について ウッシ 05/4/15(金) 11:32 回答[未読]
【24202】Re:データチェックおよび抽出について KOTARO 05/4/15(金) 13:02 発言[未読]
【24203】Re:データチェックおよび抽出について ウッシ 05/4/15(金) 13:46 回答[未読]
【24213】Re:データチェックおよび抽出について KOTARO 05/4/15(金) 18:46 発言[未読]
【24216】Re:データチェックおよび抽出について ウッシ 05/4/15(金) 20:13 回答[未読]
【24226】Re:データチェックおよび抽出について KOTARO 05/4/16(土) 0:02 発言[未読]
【24227】Re:データチェックおよび抽出について ウッシ 05/4/16(土) 0:35 回答[未読]
【24233】Re:データチェックおよび抽出について KOTARO 05/4/16(土) 13:03 発言[未読]
【24237】Re:データチェックおよび抽出について ウッシ 05/4/16(土) 15:52 回答[未読]
【24254】Re:データチェックおよび抽出について KOTARO 05/4/17(日) 20:59 お礼[未読]
【24193】Re:データチェックおよび抽出について ponpon 05/4/15(金) 1:02 発言[未読]
【24194】Re:データチェックおよび抽出について KOTARO 05/4/15(金) 8:39 お礼[未読]
【24181】データチェックおよび抽出について
質問  KOTARO  - 05/4/14(木) 17:26 -
引用なし
パスワード
   膨大なデータチェック作業が差し迫っておりまして、アドバイスいただければ
大変助かります。どうかよろしくお願いいたします。

マクロの流れ
・データの組み合わせ(下記参照)をチェックし
・ありえない組み合わせの場合該当セルを「赤」で表示
・「赤」で表示されたセルを含む行データを抽出
・新規ブック「エラーデータ.xls」に該当データのみコピー
という手順です。

※A列のセル(チェック対象外)がブランクになるまで繰り返します。
※アクティブセルは任意の位置にあります
※列タイトルは便宜上「項目1」「項目2」としていますが隣接しているとは
　限りません

基本的なチェック方法は以下のとおりです。
＜データ照合1＞
「項目1」のデータが「AAA」、「項目2」のデータが「BBB」の場合、
「項目2」のセルを赤く表示

＜データ照合2＞
「項目1」のデータが「AAA」、「項目2」のデータが「BBB」または
「CCC」の場合、「項目2」のセルを赤く表示

＜データ照合3＞
「項目1」のデータが「AAA」または「BBB」、「項目2」のデータが
「CCC」の場合、「項目2」のセルを赤く表示

＜データ照合4＞
「項目1」のデータが「AAA」、「項目2」のデータが「DDD」の場合、または
「項目1」のデータが「BBB」、「項目2」のデータが「EEE」の場合、または
「項目1」のデータが「CCC」、「項目2」のデータが「FFF」の場合、
「項目2」のセルを赤く表示

＜データ照合5＞
「項目1」のデータが「AAA」、「項目2」のデータに「BBB」(テキスト)が
含まれていない場合、「項目2」のセルを赤く表示
【24186】Re:データチェックおよび抽出について
発言  ponpon  - 05/4/14(木) 21:40 -
引用なし
パスワード
   ponponです。こんばんは。
色つけの部分だけ、よくわからないのですが・・・
まとめると、

　項目１がAAAの時、
　　項目２がBBBまたは,CCCまたは,DDD,または,BBBを含む文字列の場合に　赤
　項目１がBBBの時
　　項目２がCCCまたは,EEEの場合に　赤
　項目１がCCCの時
　　項目２がFFFの場合に　赤

ということではないのですか？

項目１は、A列、項目２は、D列で考えています。
違っていたらすみません。

Sub test()
　　Dim myRng As Range
　　Dim r As Range
　　
　　With Worksheets("sheet1")
　　 Set myRng = .Range("A2", Range("A65536").End(xlUp))
　　 For Each r In myRng
　　　Select Case r.Value
　　　Case Is = "AAA"
　　　　If r.Offset(0, 3).Value = "BBB" Or _
　　　　　 r.Offset(0, 3).Value = "CCC" Or _
　　　　　 r.Offset(0, 3).Value = "DDD" Or _
　　　　　 r.Offset(0, 3).Value <> "*BBB*" Then
　　　　　 r.Offset(0, 3).Interior.ColorIndex = 3
　　　　End If
　　　Case Is = "BBB"
　　　　If r.Offset(0, 3).Value = "CCC" Or _
　　　　　 r.Offset(0, 3).Value = "EEE" Then
　　　　　 r.Offset(0, 3).Interior.ColorIndex = 3
　　　　End If
　　　Case Is = "CCC"
　　　　If r.Offset(0, 3).Value = "FFF" Then
　　　　　 r.Offset(0, 3).Interior.ColorIndex = 3
　　　　End If
　　　End Select
　　 Next
　　End With

End Sub
【24188】Re:データチェックおよび抽出について
発言  KOTARO  - 05/4/14(木) 23:23 -
引用なし
パスワード
   ponpon さん 誠にありがとうございます。
私の説明がうまくできていなくて申し訳ありません。

・データは「AAA」…という書き方ではなく「???」とすれば
　お分かりいただけるでしょうか。
　つまり照合パターンごとにデータは変わってくるのです。
　したがいまして照合パターンごとの別個のマクロとお考えいただければ
　と思います。
・また対象データのある列ついては「"項目1"というタイトルのある列」で位置を
　特定できないでしょうか

どうかよろしくお願いいたします。
【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
【24191】Re:データチェックおよび抽出について
お礼  KOTARO  - 05/4/15(金) 0:30 -
引用なし
パスワード
   ウッシ さん　夜遅くまで考えていただきまして
誠にありがとうございます。

明日実行結果をご報告します。
【24193】Re:データチェックおよび抽出について
発言  ponpon  - 05/4/15(金) 1:02 -
引用なし
パスワード
   こんばんは。
同じAAAやBBBでも全然関係なかったのね？！？？？
初心者の私には、無理だと思います。
ウッシさんのを参考にしてください。
私にできるのは、ここまで。

Sub test3()
　　Dim myCol As Single, myCol2 As Single
　　Dim myRng As Range, myRng2 As Range
　　Dim r As Range, c As Range
　　
　　
　　With Worksheets("sheet1")
　　 Set myRng2 = .Range("A1", Range("A1").End(xlToRight))
　　 For Each c In myRng2
　　　 If c.Value = "項目１" Then
　　　　　myCol = c.Column
　　　 ElseIf c.Value = "項目２" Then
　　　　　myCol2 = c.Column
　　　 End If
　　 Next
　　 Set myRng = .Range(Cells(1, myCol), .Cells(65536, myCol).End(xlUp))
　　 For Each r In myRng
　　　Select Case r.Value
　　　Case Is = "AAA"　'照合１
　　　　If .Cells(r.Row, myCol2).Value = "BBB" Then
　　　　　 .Cells(r.Row, myCol2).Interior.ColorIndex = 3
　　　　End If
　　　Case Is = "AAA"　'照合２
　　　　If .Cells(r.Row, myCol2).Value = "BBB" Or _
　　　　　 .Cells(r.Row, myCol2).Value = "CCC" Then
　　　　　 .Cells(r.Row, myCol2).Interior.ColorIndex = 3
　　　　End If
　　　Case Is = "AAA", "BBB"　'照合３
　　　　If .Cells(r.Row, myCol2).Value = "CCC" Then
　　　　　 .Cells(r.Row, myCol2).Interior.ColorIndex = 3
　　　　End If
　　　End Select
　　 Next
　　End With
End Sub
【24194】Re:データチェックおよび抽出について
お礼  KOTARO  - 05/4/15(金) 8:39 -
引用なし
パスワード
   ponpon さん ありがとうございます。
またぜひアドバイスお願いいたします。
【24197】Re:データチェックおよび抽出について
発言  KOTARO  - 05/4/15(金) 11:17 -
引用なし
パスワード
   ウッシ さん
おはようございます。昨日はありがとうございました。

さっそくSub データ照合1()をtestデータで試してみました。
ステップ実行で確認しましたが、不備データのセルは「赤」にならず
そのまま終了しました。
(「If Not r Is Nothing Then」から「End If」に飛び、特にエラーも
出ませんでした)

またSub データ照合1()の応用編として
・「項目1」のデータが「AAA」、「項目2」のデータが「BBB」以外の場合、
　「項目2」のセルを赤く表示
・「項目1」のデータが「AAA」、「項目2」のデータが「BBB」(数値)より大きい
　の場合、「項目2」のセルを赤く表示
を考えてみたいのですが、条件式のしくみがどうしても分かりません。

お手数ですがどこを直せばよいのかご指導下さい。
どうかよろしくお願い致します。

>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
【24198】Re:データチェックおよび抽出について
回答  ウッシ  - 05/4/15(金) 11:32 -
引用なし
パスワード
   こんにちは

>「If Not r Is Nothing Then」から「End If」に飛び、特にエラーも出ませんでした
という事は不備データが無かったという事です。

>※アクティブセルは任意の位置にあります
アクティブセルの行以下をチェックというは前スレから変わりないのですよね？

一応、動作確認してコードはレスしてます。

>・「項目1」のデータが「AAA」、「項目2」のデータが「BBB」以外の場合、「1」
>・「項目1」のデータが「AAA」、「項目2」のデータが「BBB」(数値)より大きい
>　　場合、「1」
になる数式を考えて下さい。

今回のコードは一般操作の数式を利用しています。
判定条件をセルの数式で表現出来ればコードの修正も出来る様になります。
【24202】Re:データチェックおよび抽出について
発言  KOTARO  - 05/4/15(金) 13:02 -
引用なし
パスワード
   ウッシ さん

お手数をおかけします。
確かにコード通りのデータベースですと見事に抽出されました。
すごいです。ありがとうございました。

実際のデータベースにはチェックの対象である「項目2」のデータが
「数値の1」であるため、

Const 項目2_Dat As Variant = 1

と変更したのですが、この部分の記述に問題があるのでしょうか
【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
【24213】Re:データチェックおよび抽出について
発言  KOTARO  - 05/4/15(金) 18:46 -
引用なし
パスワード
   ウッシ さん
どうもありがとうございました。
見事に不備データを抽出できました。
これで項目1、項目2…のデータが数値/テキストどちらでもチェック
可能ということですね。

この作業に相当の時間と労力を割いていましたので、かなりの
効率化が期待できそうです。応用編を自分なりに工夫してみます。

最後にひとつお願いですが、このチェック作業は30項目以上にわたりますので、
マクロを実行させるつど同じ名前のファイルが出来てしまいます。
そこで今回のマクロを
・データチェック()…不備データのセルを「赤」で表示する
・データ抽出()　　…「赤」で表示されたセルのある行データを追加した
　　　　　　　　　　別シートにコピー(アクティブセルの位置に関係なく)

という具合に分離できませんでしょうか。
いろいろお手数をおかけしてすみませんがよろしくお願いいたします。
【24216】Re:データチェックおよび抽出について
回答  ウッシ  - 05/4/15(金) 20:13 -
引用なし
パスワード
   こんばんは

>・データチェック()…不備データのセルを「赤」で表示する
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

>・データ抽出()　　…「赤」で表示されたセルのある行データを追加した
>　　　　　　　　　　別シートにコピー(アクティブセルの位置に関係なく)
30項目以上のチェックが終了した時点でという事でしょうか？
それぞれ別の列に「赤」で表示されたセルが有るとすると全セルの色を調べて
抽出する事になりちょっと大変です。
それぞれのチェックを行う毎に特定のシートに累積しておくのはダメでしょうか？
【24226】Re:データチェックおよび抽出について
発言  KOTARO  - 05/4/16(土) 0:02 -
引用なし
パスワード
   ▼ウッシ さん：
>>・データ抽出()　　…「赤」で表示されたセルのある行データを追加した
>>　　　　　　　　　　別シートにコピー(アクティブセルの位置に関係なく)
>30項目以上のチェックが終了した時点でという事でしょうか？
>それぞれ別の列に「赤」で表示されたセルが有るとすると全セルの色を調べて
>抽出する事になりちょっと大変です。
>それぞれのチェックを行う毎に特定のシートに累積しておくのはダメでしょうか？

お世話になります。ウッシさんのおっしゃるとおりですね。
ただ、今のイメージでは一項目のチェックを複数回のマクロで行う
ことになると思います(私の力では一度に終わらせる複雑な式が出来ないので)

その場合、チェックを重ねていくと同じ項目(列)に赤セルが徐々に
増えていきますので、
>それぞれのチェックを行う毎に特定のシートに累積
ですと、すでに抽出(コピー)済みデータとの判別ができないのでは？

ある項目のチェックがひととおり終わった任意の時点で、「その項目に
赤セルのある行データを別シートにコピーするマクロ」ということに
なりますでしょうか。

ご意見をお聞かせください。
【24227】Re:データチェックおよび抽出について
回答  ウッシ  - 05/4/16(土) 0:35 -
引用なし
パスワード
   ▼KOTARO さん：
>▼ウッシ さん：
>>>・データ抽出()　　…「赤」で表示されたセルのある行データを追加した
>>>　　　　　　　　　　別シートにコピー(アクティブセルの位置に関係なく)
>>30項目以上のチェックが終了した時点でという事でしょうか？
>>それぞれ別の列に「赤」で表示されたセルが有るとすると全セルの色を調べて
>>抽出する事になりちょっと大変です。
>>それぞれのチェックを行う毎に特定のシートに累積しておくのはダメでしょうか？
>
>お世話になります。ウッシさんのおっしゃるとおりですね。
>ただ、今のイメージでは一項目のチェックを複数回のマクロで行う
>ことになると思います(私の力では一度に終わらせる複雑な式が出来ないので)
>
>その場合、チェックを重ねていくと同じ項目(列)に赤セルが徐々に
>増えていきますので、
>>それぞれのチェックを行う毎に特定のシートに累積
>ですと、すでに抽出(コピー)済みデータとの判別ができないのでは？
>
>ある項目のチェックがひととおり終わった任意の時点で、「その項目に
>赤セルのある行データを別シートにコピーするマクロ」ということに
>なりますでしょうか。
>
>ご意見をお聞かせください。

こんばんは

同じデータに、30項目以上のチェックをするという事でデータそのものの行位置が
変わらないのであれば転記する際に元の行と同じ行にコピーしていけばいいかも？

最終的に全く不備と判定されなかった行は空になっていると思いますので最後に
空白行削除すればいいです。

チェックの意味自体が良く分からないのでなんとも言えないですけど・・・。
【24233】Re:データチェックおよび抽出について
発言  KOTARO  - 05/4/16(土) 13:03 -
引用なし
パスワード
   ▼ウッシ さん
>同じデータに、30項目以上のチェックをするという事でデータそのものの行位置が
>変わらないのであれば転記する際に元の行と同じ行にコピーしていけばいいかも？
>
>最終的に全く不備と判定されなかった行は空になっていると思いますので最後に
>空白行削除すればいいです。
>
>チェックの意味自体が良く分からないのでなんとも言えないですけど・・・。

ウッシさん
お世話になります。
なるほどそういう方法がありましたね。
行の移動はありませんので上記の方法で結構です。

あと下記のとおり修正し実行してみたのですが、チェックできず終了
してしまいました。
コメントアウトしてしまうと「赤」で表示するという記述がなくなって
しまうのではないでしょうか。
お手数ですがこの点についてもご確認下さい。

>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
【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_空白行削除()」はチェックが全て終了したら実行して下さい。
【24254】Re:データチェックおよび抽出について
お礼  KOTARO  - 05/4/17(日) 20:59 -
引用なし
パスワード
   ウッシ さん
誠にありがとうございました。

初心者のわがままな質問におつきあい
いただきまして恐縮しております。
今回のマクロについては、とてもありがたく、
使わせていただきます。

まだまだ勉強不足ですが、また機会がありましたら
アドバイスをお願いいたします。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
10014 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free