Excel VBA質問箱 IV

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

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


1426 / 13645 ツリー ←次へ | 前へ→

【74535】マクロを用いたエラー値の削除 argon 13/7/18(木) 19:58 質問[未読]
【74539】Re:マクロを用いたエラー値の削除 γ 13/7/19(金) 8:45 発言[未読]
【74540】Re:マクロを用いたエラー値の削除 γ 13/7/19(金) 23:47 発言[未読]
【74550】Re:マクロを用いたエラー値の削除 argon 13/7/21(日) 23:49 回答[未読]
【74551】Re:マクロを用いたエラー値の削除 γ 13/7/22(月) 20:05 発言[未読]
【74556】Re:マクロを用いたエラー値の削除 argon 13/7/23(火) 22:03 発言[未読]
【74559】Re:マクロを用いたエラー値の削除 γ 13/7/24(水) 8:10 発言[未読]

【74535】マクロを用いたエラー値の削除
質問  argon  - 13/7/18(木) 19:58 -

引用なし
パスワード
   対象データ 3D座標データ(x,y,z)
A列:x座標データ番号
B列:y座標データ番号
C列:x座標データ
D列:y座標データ
E列:z座標データ

目的:z座標にエラー値(周囲とは明らかに異なった値)を含む場合、
   1.その値を含む行を削除
   2.そのz座標と同じ行にあるy座標データ番号を取得
   3.B列を検索してy座標データ番号が等しいものを含む行をすべて削除

エラー値の基準:1.x座標データ番号が1であること
        2.Z座標が(最大値と最小値の差)*2/3+最小値よりも大きいこと

例:A列10行に1
  B列10行に20
  E列10行にエラー値があった場合

  B列が20となっている行を全て削除
  削除後に、またエラー値を検索して、
  エラー値を発見したらそのB列の値を取得し
  B列中にその値をもつ行を全て削除

  これをエラー値がなくなるまで継続(ループ)

トライしたこと:エラー値を含む行を削除するマクロとして"エラー"という値を含むマクロは作成できたため、これを応用して作成しようと思ったが、どうやって値を取得して、B列を検索させればいいかわからず途方に暮れています。

最初に作った、エラー値を作るマクロ↓

------------------------------

 Dim lRow As Long
 Dim i As Long
 
  Worksheets("Sheet1").Activate
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  Application.ScreenUpdating = False
  For i = lRow To 2 Step -1
    If Cells(i, 5).Value = "エラー" Then
      Cells(i, 5).EntireRow.Delete
    End If
  Next i
  Application.ScreenUpdating = True

---------------------------------------------------
何卒、アドバイスをお願い致します。

【74539】Re:マクロを用いたエラー値の削除
発言  γ  - 13/7/19(金) 8:45 -

引用なし
パスワード
   エラー値というかアウトライアー(外れ値)という意味ですね。

F列を作業列に使って、
まずは削除すべき対象行のF列セルに 1 を立てる(記入する)作業を
書いて見てはどうでしょう。正しい判定処理かの確認にもなりますし。

それが完成したあとで、
・1が立っている行を、下から順に削除するか、
・F列でソートして、1の立っている行だけを対象に纏めて削除する
といったことを検討されたほうが近道だと思います。

【74540】Re:マクロを用いたエラー値の削除
発言  γ  - 13/7/19(金) 23:47 -

引用なし
パスワード
   考え方は、
(1)E列がerrorになっている時の、B列の値(y座標番号)を
  Dictionaryに登録する。

(2)各行をしたから見ていって、B列がその登録したy座標番号なら、
  その行を削除する。

Sub test()
  Dim dic As Object
  Dim lastRow As Long
  Dim k As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  lastRow = Cells(Rows.Count, 1).End(xlUp).Row
  
  For k = 2 To lastRow
    If Cells(k, 5).Value = "error" Then ''例示です。
      dic(Cells(k, 2).Value) = Empty
    End If
  Next

  For k = lastRow To 2 Step -1
    If dic.Exists(Cells(k, 2).Value) Then
      '' Rows(k).Delete
      Cells(k, 6).Value = 1
    End If
  Next

End Sub

なお、上記ではerror かどうかの判定はできているものとしていますが、
ここも数式で判定するということなら、確認が必要な点があります。
> Z座標が(最大値と最小値の差)*2/3+最小値よりも大きいこと
この最大、最小とはどのような範囲での最大最小なのですか?
全ての範囲ですか?
それとも、特定の範囲に絞ってということはありますか
(例:x座標データ番号が1のものに限定するとか)

【74550】Re:マクロを用いたエラー値の削除
回答  argon  - 13/7/21(日) 23:49 -

引用なし
パスワード
   γさん

回答有り難うございます。
返信が遅れてしまい申し訳ありません。

以前の解答で検出用セルに1を立てるということで、
マクロ作成にトライしておりました。

作成したマクロを以下に示しますが、
これだと、A列が1の時にしか1を立ててくれませんでした。

>なお、上記ではerror かどうかの判定はできているものとしていますが、
>ここも数式で判定するということなら、確認が必要な点があります。
>> Z座標が(最大値と最小値の差)*2/3+最小値よりも大きいこと
>この最大、最小とはどのような範囲での最大最小なのですか?
>全ての範囲ですか?
>それとも、特定の範囲に絞ってということはありますか
>(例:x座標データ番号が1のものに限定するとか)

検出範囲としては、Z座標すべて(E列全て)の範囲です。

>考え方は、
>(1)E列がerrorになっている時の、B列の値(y座標番号)を
>  Dictionaryに登録する。

Dictionaryに登録という手法自体知らなかったです...。
次回に活かせるよう精進します。


-----------作成したマクロのコード-----------

Sub エラー値検出()
'
' エラー値検出 Macro
' 不正値を削除
'

 Dim lRow As Long
 Dim i As Long
 Dim izmax As Long
 Dim izmin As Long
 Dim iz As Long
 Dim izval As Integer


Worksheets("Sheet1").Activate
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  izmax = Application.WorksheetFunction.Max(Cells(Rows.Count, 5).End(xlUp))
  izmin = Application.WorksheetFunction.Min(Cells(Rows.Count, 5).End(xlUp))
  iz = izmin + ((izmax - izmin) / 3)
  Application.ScreenUpdating = False

  For i = lRow To 2 Step -1
   If Cells(i, 5).Value > iz And Cells(i, 1).Value = 1 Then
    Cells(i, 6).Value = 1
   End If
  Next i

  Application.ScreenUpdating = True

  For i = lRow To 2 Step -1
   If Cells(i, 6).Value = 1 Then
    izval = Cells(i, 2).Value
   End If

   If Cells(i, 2).Value = izval Then
    Cells(i, 7).Value = 1
   End If
  Next i
'

End Sub

【74551】Re:マクロを用いたエラー値の削除
発言  γ  - 13/7/22(月) 20:05 -

引用なし
パスワード
   こんな感じになりませんか?参考にしてください。

Sub test()
  Dim dic   As Object
  Dim lastRow As Long
  Dim myRange As Range
  Dim myMax  As Double, myMin As Double
  Dim target As Double
  Dim v    As Double
  Dim k    As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  lastRow = Cells(Rows.Count, 1).End(xlUp).Row
  
  '基準値の作成
  Set myRange = Range(Cells(2, 5), Cells(Rows.Count, 5).End(xlUp))
  myMax = Application.WorksheetFunction.Max(myRange)
  myMin = Application.WorksheetFunction.Min(myRange)
  target = myMin + (myMax - myMin) * 2 / 3

  'x座標番号が1 かつ z座標が基準値を超えていたら、
  '対応するy座標番号 を Dictionaryに保存
  For k = 2 To lastRow
    v = Cells(k, 5).Value
    If Cells(k, 1).Value = 1 And v > target Then
      dic(Cells(k, 2).Value) = Empty
    End If
  Next

  'そのy座標番号のデータをすべて削除する
  For k = lastRow To 2 Step -1
    If dic.Exists(Cells(k, 2).Value) Then
      '' Rows(k).Delete
      Cells(k, 6).Value = 1
    End If
  Next
End Sub

【74556】Re:マクロを用いたエラー値の削除
発言  argon  - 13/7/23(火) 22:03 -

引用なし
パスワード
   γ さんのコードを参考にしたら無事動きました。

本当にありがとうございます。

ただ、エラー値が多いと完了まで5分ぐらいかかってしまいます。

もし、時間短縮の手法についてご存知でしたら、教えていただけるとありがたいです。

↓今回作成したマクロ

---------------------------------------------------

Sub エラー値検出()
'
' エラー値検出 Macro
'

 Dim dic As Object
 Dim lRow As Long
 Dim izRange As Range
 Dim izmax As Double
 Dim izmin As Double
 Dim iz As Double
 Dim z As Variant '←型の不一致エラーのためVariantに変更
 Dim i As Long
 
Worksheets("Sheet1").Activate
  
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  Set dic = CreateObject("Scripting.Dictionary")
  
  '基準値の作成
  Set izRange = Range(Cells(26, 5), Cells(Rows.Count, 5).End(xlUp))
  izmax = Application.WorksheetFunction.Max(izRange)
  izmin = Application.WorksheetFunction.Min(izRange)
  iz = izmin + ((izmax - izmin) / 3)
  
  Application.ScreenUpdating = False
  
  'x座標番号が1 かつ z座標が基準値を超えていたら、
  '対応するy座標番号 を Dictionaryに保存
  
  For i = 2 To lRow
   z = Cells(i, 5).Value
   If z > iz And Cells(i, 1).Value = 1 Then
    dic(Cells(i, 2).Value) = Empty
    End If
  Next
  
  'そのy座標番号のデータをすべて削除する
  For i = lRow To 2 Step -1
  If dic.Exists(Cells(i, 2).Value) Then
      Rows(i).Delete
      ''Cells(i, 6).Value = 1
    End If
  Next
  
  Application.ScreenUpdating = True
 

'

End Sub

【74559】Re:マクロを用いたエラー値の削除
発言  γ  - 13/7/24(水) 8:10 -

引用なし
パスワード
   計算処理は高速のはずで、問題は削除処理のはず。
すでに書きましたが、
>・F列でソートして、1の立っている行だけを対象に纏めて削除する
ことで削除処理が早くなるはずです。

昇順でソートすると数値の1が先にきますので、
Endプロパティで1が立っている最終行を求めて、
2行目(タイトル行の次行の意)からその行までを纏めて削除すればいいでしょう。
コードは示しませんが、トライしてみて下さい。

今のものでも、
処理の最初にApplication.Calculationを手動に変えて、
処理の最後に自動に戻すということをやっても
効果はありそうな気がします。

1426 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free