[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『指定した№をメッセージボックス複数削除したいんですが？』（ピン）
Dim myNo As String
Dim myRange As Range
'確認メッセージの表示（キャンセルの場合マクロを抜ける）
If MsgBox("データの登録データを削除しますか。", vbOKCancel + 32, "削除確認") = vbCancel Then
Exit Sub
End If
InputData:
Sheets("ﾃﾞｰﾀ").Select
Range("A65536").Select
'下から空白の行を選択する。
Selection.End(xlUp).Select
'1つ行のセルのを選択
ActiveCell.Offset(0, 0).Select
myNo = Application.InputBox("削除したい№を選択してください！" _
, "№指定", ActiveCell.Value, 1)
'<何も入力せずOKの場合、再入力します。>
If myNo = "" Then
MsgBox "未入力です。", 16, "再確認"
GoTo InputData
End If
'<キャンセルの場合、処理を終わりにします。>
If myNo = "False" Then
Sheets("入力").Select
Exit Sub
End If
'№ををA行から検索
Set myRange = Range("A2:A60000").Find(myNo)
'№が見つからない場合
If myRange Is Nothing Then
'元のシートに戻る
MsgBox "該当する№はありません。", 16, "再確認"
GoTo InputData
Else
'シート保護解除
ActiveSheet.Unprotect
'検索した№を選択して削除
myRange.Cells.Select
Selection.EntireRow.Delete Shift:=xlUp
'元のシートに戻る
Sheets("入力").Select
Range("ｈ6").Select
MsgBox "№" & (myNo) & "の削除が終わりました。", 64, "削除終了確認"
End If
Call 並び替え実行
End Sub
コードとしては シート.Select とか セル.Select 使わないほうがいいとか 65536 という【マジックナンバー】は使わないほうがいいとか 何よりも、ループ制御で、 GoTo ラベル は、コードを書くときは簡単で楽ちんだけど、あとで見たときに わかりにくくなるのと、今後追加改訂をしていくときに、時としてバグの大きな要因になるといった保守性の面で 【絶対に使うべきではない】とか、いろいろあるけど、さておき。
要望は
No2,No5-No6,No12,・・・ といった指定をしたいということかな？
(ぶらっと)
ということは、指定するものが行番号 ということ？
アップされたコードでは、この入力された値、仮に 10 だとすると、この10 で Set myRange = Range("A2:A60000").Find(myNo) と
直接検索しているけど？？？
このコードの意味は？
行番号なら、今、こちらで書いたコードよりもっとすっきりした簡単なものになるけど、ほんとにそれでいいの？
あっと。もしかして、A列には、必ず No10 というように "No"が頭についた数字が入っていて、 指定された数字に No.をつけて検索したいということかな？
いずれにしても、実際に Ａ列にはどんな値が入っているのか、で、それを削除するために どのような文字列で指定したいのか、サンプルで説明してくれる？
(ぶらっと)
指定しているのは行番号なんですが・・
すみません分かりにくい説明で。
（ピン）
ということは、A2から下には、たぶん 1,2,3,4・・・とあるんだろうけど、とにかく数字がある。 (以下のコード処理上は、連番じゃなくても、また数字じゃなくてもいいんだけど） で、たとえば 2-4 と指定すると、行としては (このサンプルでは）3行目から 5行目を削除するということだね。
それなら、以下のコードで試してみて。 入力は、1-10,15,18 といった要領で。
ただし、これは行番号じゃないよ。 A列に1と入っている最初の行からA列に10と入っている最初の行までを削除。 A列に15 と入っている最初の行を削除、A列に18と入っている最初の行を削除。
こんなロジック。
そうじゃなく、A列にどんな値が入っていようと、2行目～11行目、16行目、19行目を削除するなら 少しシンプルなコードになるんだけど。
Sub Sample()
Dim myAns As String
Dim okflag As Boolean
Dim myR As Range
'確認メッセージの表示（キャンセルの場合マクロを抜ける）
If MsgBox("データの登録データを削除しますか。", vbOKCancel + 32, "削除確認") = vbCancel Then Exit Sub
With Sheets("ﾃﾞｰﾀ")
'A列最後のデータの値（初期値として）
myAns = .Range("A" & .Rows.Count).End(xlUp).Value
Do
okflag = False
myAns = Application.InputBox("削除したい№を選択してください！" _
, "№指定", myAns, 1)
If myAns = "False" Then Exit Sub 'キャンセルボタン
If Len(myAns) = 0 Then
MsgBox "未入力です。", 16, "再確認"
Else
Set myR = CheckStr(.Columns("A"), myAns)
If myR Is Nothing Then
MsgBox "該当する№はありません。", 16, "再確認"
Else
myR.EntireRow.Delete
MsgBox myAns & "の削除が終わりました。", 64, "削除終了確認"
'元のシートに戻る
Application.Goto Sheets("入力").Range("ｈ6")
Call 並び替え実行
okflag = True
End If
End If
Loop While Not okflag
End With
End Sub
Private Function CheckStr(a As Range, s As String) As Range
Dim v1 As Variant
Dim d1 As Variant
Dim v2 As Variant
Dim d2 As Variant
Dim ansR As Range
Dim r As Range
Dim c1 As Range
Dim c2 As Range
Dim i1 As Long
Dim i2 As Long
Dim ok As Boolean
ok = True
v1 = Split(s, ",") ' "," 区切りで分解
For Each d1 In v1
v2 = Split(d1, "-") ' その中身を "-" 区切りで分解
If UBound(v2) > 1 Then
ok = False ' - でくぎられたブロックが３つ以上ならエラー
Exit For
End If
Set c1 = a.Find(What:=v2(0), LookAt:=xlWhole)
If c1 Is Nothing Then
ok = False
Exit For
End If
If UBound(v2) = 1 Then
Set c2 = a.Find(What:=v2(1), LookAt:=xlWhole)
If c2 Is Nothing Then
ok = False
Exit For
End If
End If
i1 = c1.Row
i2 = 0
If UBound(v2) = 1 Then i2 = c2.Row
If i2 = 0 Then
Set r = c1
Else
If i1 > i2 Then
ok = False
Exit For
End If
Set r = c1.Resize(i2 - i1 + 1)
End If
If ansR Is Nothing Then
Set ansR = r
Else
Set ansR = Union(ansR, r)
End If
If Not ok Then Exit For
Next
If ok Then Set CheckStr = ansR
End Function
(ぶらっと)
myR.EntireRow.Deleteの部分でデバックになってしまうんですが？ どうしてですか？ (ピン）
どうしてといわれても・・・
コードとしては、
If myR Is Nothing Then
MsgBox "該当する№はありません。", 16, "再確認"
Else
myR.EntireRow.Delete
myRに有効なアドレスがある場合のみ処理しているので・・・
実際に表示されたメッセージの内容と、InputBoxで、どんな文字列を入力したか教えてくれる？
シートが保護ざれているなんてことはないんだよねぇ・・・
(ぶらっと)
myR.EntireRow.Delete
これを
myR.EntireRow.Range("A1:Q1").Delete Shift:=xlUp
(ぶらっと)
関数で参照しているセルが削除されると、行削除であろうが、セル領域削除であろうが #REF! になってしまうね？
ちょっとわからないのは、最初にそちらでアップしたコードって、実際に使っていたものではないの？ もし、使っていたとしたらシート保護の件もそうなんだけど、削除したら、その時点で #REF! は発見できていたのでは？
それとも、アップしたコードは実際に使ったことがなかったのかな？
いずれにしても、以下のようなこと？
先ほど連絡した
myR.EntireRow.Range("A1:Q1").Delete Shift:=xlUp
この後に
.Range("R2:R" & .Range("R" & .Rows.Count).End(xlUp).Row).Formula = "=IF(H2="""","""",COUNTIF(H$2:H2,H2))"
(ぶらっと)
（ピン）
>1-10 といった要領で入力しているのですが、1つだけしか削除されないようなんですが・・？
A2から下に1,2,3,4・・・・・・・,99,100 と A101まで連番をふって、今、目の前で 1-10 を入れたけど ちゃんと10行削除されているけどなぁ？？
それとも、１つだけというのが 1-10,20,30-35 と複数ブロック指定した１つだけということ？ これについても、ちゃんと指定したものがすべて削除されているけどねぇ、こちらでは。
追記）ごめん！ごめん！ 古いバージョン（行全体を削除）でテストしていた。 新しいバージョンでは、確かに！！ のちほど修正してアップするね。
(ぶらっと)
Sample を入れ替え。CheckStr は変更なし。
Sub Sample()
Dim myAns As String
Dim okflag As Boolean
Dim myR As Range
Dim myA As Range
'確認メッセージの表示（キャンセルの場合マクロを抜ける）
If MsgBox("データの登録データを削除しますか。", vbOKCancel + 32, "削除確認") = vbCancel Then Exit Sub
With Sheets("ﾃﾞｰﾀ")
'A列最後のデータの値（初期値として）
myAns = .Range("A" & .Rows.Count).End(xlUp).Value
Do
okflag = False
myAns = Application.InputBox("削除したい№を選択してください！" _
, "№指定", myAns, 1)
If myAns = "False" Then Exit Sub 'キャンセルボタン
If Len(myAns) = 0 Then
MsgBox "未入力です。", 16, "再確認"
Else
Set myR = CheckStr(.Columns("A"), myAns)
If myR Is Nothing Then
MsgBox "該当する№はありません。", 16, "再確認"
Else
For Each myA In myR.Areas
myA.EntireRow.Columns("A:Q").Delete Shift:=xlUp
Next
.Range("R2:R" & .Range("A" & .Rows.Count).End(xlUp).Row).Formula = "=IF(H2="""","""",COUNTIF(H$2:H2,H2))"
MsgBox myAns & "の削除が終わりました。", 64, "削除終了確認"
'元のシートに戻る
Application.Goto Sheets("入力").Range("ｈ6")
' Call 並び替え実行
okflag = True
End If
End If
Loop While Not okflag
End With
End Sub
(ぶらっと)
↑のコードでも目的は達成できるけど、行全体を削除する最初のコードに、急遽、間に合わせで A-Qのみの削除をいれたもの。 最初からA-Q削除を前提にすれば以下のほうがすっきりする。 フルセット入れ替え。
Sub Sample()
Dim myAns As String
Dim okflag As Boolean
Dim myR As Range
'確認メッセージの表示（キャンセルの場合マクロを抜ける）
If MsgBox("データの登録データを削除しますか。", vbOKCancel + 32, "削除確認") = vbCancel Then Exit Sub
With Sheets("ﾃﾞｰﾀ")
'A列最後のデータの値（初期値として）
myAns = .Range("A" & .Rows.Count).End(xlUp).Value
Do
okflag = False
myAns = Application.InputBox("削除したい№を選択してください！" _
, "№指定", myAns, 1)
If myAns = "False" Then Exit Sub 'キャンセルボタン
If Len(myAns) = 0 Then
MsgBox "未入力です。", 16, "再確認"
Else
Set myR = CheckStr(.Columns("A"), myAns)
If myR Is Nothing Then
MsgBox "該当する№はありません。", 16, "再確認"
Else
myR.Delete Shift:=xlUp
.Range("R2:R" & .Range("A" & .Rows.Count).End(xlUp).Row).Formula = "=IF(H2="""","""",COUNTIF(H$2:H2,H2))"
MsgBox myAns & "の削除が終わりました。", 64, "削除終了確認"
'元のシートに戻る
Application.Goto Sheets("入力").Range("ｈ6")
' Call 並び替え実行
okflag = True
End If
End If
Loop While Not okflag
End With
End Sub
Private Function CheckStr(a As Range, s As String) As Range
Dim v1 As Variant
Dim d1 As Variant
Dim v2 As Variant
Dim d2 As Variant
Dim ansR As Range
Dim r As Range
Dim c1 As Range
Dim c2 As Range
Dim i1 As Long
Dim i2 As Long
Dim ok As Boolean
ok = True
v1 = Split(s, ",") ' "," 区切りで分解
For Each d1 In v1
v2 = Split(d1, "-") ' その中身を "-" 区切りで分解
If UBound(v2) > 1 Then
ok = False ' - でくぎられたブロックが３つ以上ならエラー
Exit For
End If
Set c1 = a.Find(What:=v2(0), LookAt:=xlWhole)
If c1 Is Nothing Then
ok = False
Exit For
End If
If UBound(v2) = 1 Then
Set c2 = a.Find(What:=v2(1), LookAt:=xlWhole)
If c2 Is Nothing Then
ok = False
Exit For
End If
End If
i1 = c1.Row
i2 = 0
If UBound(v2) = 1 Then i2 = c2.Row
If i2 = 0 Then
Set r = c1.Resize(, 17)
Else
If i1 > i2 Then
ok = False
Exit For
End If
Set r = c1.Resize(i2 - i1 + 1, 17)
End If
If ansR Is Nothing Then
Set ansR = r
Else
Set ansR = Union(ansR, r)
End If
If Not ok Then Exit For
Next
If ok Then Set CheckStr = ansR
End Function
(ぶらっと)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.