[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『(マクロ) InputBoxでセルを再選択させる方法について』（マイン）
先程はアドバイスありがとうございます。
現在、セル範囲の移動(転記)処理をマクロで作成しております。
処理の流れは大まかに以下になります。
・一つのシート内に曜日毎に一覧表があります。
・各曜日にグループごとに氏名他情報が入力されてあり、表になっています。
・グループとグループの間には空白セルがあります。
(イメージ)
A A
B B
C C
(マクロ実行例) Bグループを Cグループの下へ移動
A A
C C
B B
・上記は単純な例ですが実際の表では、5〜10人で人グループが幾つかあります。 ・入替えの方法は、移動(転記元)させたいグループ範囲を配列に格納し元データはクリア。 ・インプットボックスで移動先(転記先)セルを選択して配列から転記。
※配列に格納して、移動元データををクリアにしている理由
・移動先が、移動元の1行や2行下に移動する場合があり、元データを消しておく必要がある。 ・インプットボックスで移動させるのをキャンセルした際に、元データを、配列から元の位置に戻す必要がある。
わかりにくいかと思いますが、大まかな流れになります。
(質問ですが)
InputBoxを使用しセル選択をさせる際、条件を満たさない場合に再選択をさせる部分があります。
動作確認を3パターン試したところ
・初回InputBox表示後キャンセルボタン実行・・・(成功)
・初回InputBoxからのセル選択・セル再選択ともに条件を満たすパターンで実行・・・・(成功)
・条件を満たさない条件で実行
InputBox再入力が実行される→あえてキャンセルボタン実行・・・(キャンセルが効かない)
→再び、再度選択が繰り返されます。
コード内でおかしいと思う部分は以下の部分です。
'転記先を選択--------------★再入力時はここに戻る
'キャンセル時--------------★再入力時に限りキャンセルが効かない
'条件不一致時--------------★再選択促す
すみません皆様
何卒アドバイスのほど宜しくお願いいたします。
実際のコードは以下です。
Sub 指定セル領域の転記()
Dim sh1 As Worksheet: Set sh1 = Worksheets("グループ表")
'セル選択ミス回避
If IsEmpty(ActiveCell) Then Exit Sub
Dim Col As Long: Col = Selection.Column
Select Case Col
Case 3, 8, 13, 18, 23, 28, 33
Case Else: MsgBox "名前列を選択してください": Exit Sub
End Select
'Application.ScreenUpdating = 0
With sh1
'転記元データ領域の取得
Dim Tr As Long, Er As Long, a As Long
Tr = ActiveCell.CurrentRegion.Rows(1).Row '本来先頭行
Er = ActiveCell.CurrentRegion(ActiveCell.CurrentRegion.Count).Row '本来最終行
a = ActiveCell.CurrentRegion.Rows.Count '領域内個数
'一旦、配列に転記元データ領域を格納。そして転記元範囲のデータをクリアにする
※転記先が転記元データ範囲内となることもあるため
Dim v As Variant: v = .Range(.Cells(Tr, Col - 1), .Cells(Er, Col + 2)) '転記元格納
With .Range(.Cells(Tr, Col - 1), .Cells(Er, Col + 2))
.Value = ""
.Borders.LineStyle = xlNone
.Interior.ColorIndex = 0
End With
'転記先を選択させる--------------★再入力時はここに戻る
p1:
Dim Target As Range
Application.DisplayAlerts = False
On Error Resume Next
Set Target = Application.InputBox("貼り付け先を選択してください", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
'キャンセル時--------------★再入力時に限りキャンセルが効かない
If Target Is Nothing Then
MsgBox "キャンセルされました"
'元の位置に転記元データを戻す
.Cells(Tr, Col - 1).Resize(UBound(v), 4).Value = v
With .Range(.Cells(Tr, Col), .Cells(Er, Col + 2)) '作表
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlHairline
End With
Exit Sub
Else'実行時
'正しくセルが選択されているか判定
Dim r As Long, rr As Long, c As Long
r = Target.Row
'転記先の上書き回避：転記元の行個数と転記起点セルから最終行までの行個数調べ比較
rr = .Cells(r, Col).End(xlDown).Row
c = .Range(.Cells(r, Col), .Cells(rr, Col)).Rows.Count
If c < a Then '下の表と重なるか確認
MsgBox "貼付け先が他の表と重なります。再度、貼付け先を選択してください。"
GoTo p1 '--------------★再選択促す
'正しくセルが選択されている場合は以下処理
Else
.Cells(r, Col - 1).Resize(UBound(v), 4).Value = v '値のみ転記しておく
'転記先の作表範囲を特定
Dim x As Long, y As Long
x = .Range(.Cells(r, Col).Address).CurrentRegion.Rows(1).Row
If .Cells(x, Col).Offset(0, 2).Value = "" Then
Tr = x + 1
Else
Tr = x
End If
y = .Range(.Cells(r, Col).Address).CurrentRegion(.Range(.Cells(r, Col).Address).CurrentRegion.Count).Row
If .Cells(y, Col).Offset(0, 2).Value = "" Then
Er = y - 1
Else
Er = y
End If
'特定されたエリアに作表
With .Range(.Cells(Tr, Col), .Cells(Er, Col + 2))
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlHairline
End With
End If
End If
End With
'Application.ScreenUpdating = 1
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
せっかく、 Application.InputBoxでRangeオブジェクトをつかむ方法をおぼえたんですから「Selection」や「ActiveCell」ありきのコードにしないほうが、読んでてわかりやすい（＝メンテナンスしやすい）ようにおもいます。
＞コード内でおかしいと思う部分は以下の部分です。
＞'転記先を選択--------------★再入力時はここに戻る
＞'条件不一致時--------------★再選択促す
そこにもどるとまずいってことです？
↓なんだから、そういう仕様にしたのはご自身なのでは？
GoTo p1
＞ 'キャンセル時--------------★再入力時に限りキャンセルが効かない
要はキャンセルだったとき↓がTrueになる必要があるってことですよね？
If Target Is Nothing Then
それなら、前回値をリセットしておかないとダメでしょう
On Error Resume Next
Set Target =Nothing '←ここでリセット
Set Target = Application.InputBox("貼り付け先を選択してください", Type:=8)
On Error GoTo 0
（もこな２ ） 2020/05/20(水) 01:49
Set Target =Nothing
これ一つで正常に動作しました。ありがとうございます。
「Selection」や「ActiveCell」の部分の可読性を検討してまいります。
わかりにくい説明にお付き合い頂きありがとうございました。
（マイン） 2020/05/20(水) 08:58
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.