[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『(マクロ) 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
(もこな2 ) 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.