対話型で入力された情報にて処理を行うマクロ(続）

質問

ここで教えていただいた記述をバージョンアップさせたいです。

仕様と記述

１．インプットBOX－１
　　「対象値のある列を入力してください」
　　入力例：Ｇ
↓↓
２．メッセージボックス
　　「列挿入しそこに転記しますか？」
　　YES/NO　選択
↓↓
３．YESの場合
　　インプットBOX－２
　　「挿入したい列を入力してください。例：Ｈ列とI列の間→Ｈ」
　　入力例：Ｈ

　　NOの場合
　　インプットBOX－３
　　「転記する列を入力してください」
　　入力例：Ｊ

インプットBOX－１に入力された値の列を対象列として
Select Caseの条件で編集して
インプットBOX－２又は３に入力された値の列に転記します。
対象列にデータがあるまで処理を繰り返します。

バージョンアップさせたい内容

（１）
インプットBOX－１，２，３はエクセルの列の入力なので
Ａ～ＩＶ以外の入力はエラーとして
「入力値が違います。A～IV　のいずれかを入力してください。再入力しますか？」
でＯＫをクリックすると再入力可能に

（２）
インプットBOX－２
インプットBOX－１で入力した値より前の値はエラーとする
「対象列がずれます。●●以外を入力してください。再入力しますか？」
ＯＫをクリックで再入力可能に。

例：インプットBOX－１にＣと入力した場合Ａ，Ｂ，Ｃはエラー
　　となる。●●の所にその値を表示する。

（３）
インプットBOX－３
インプットBOX－１で入力した値と同じ値の場合はエラーとする。
「対象列の元の値が削除されたてしまいます。●●以外を入力してください。再入力しますか？」
ＯＫをクリックで再入力可能に。

例：インプットBOX－１にＣと入力した場合Ｃはエラーとなる。
　　●●の所にその値を表示する。

（１）（２）（３）の記述を教えてください。お願いします。

以下が現在の記述です。
↓↓↓
Sub ハイフン挿入02()
'2010年11月24日

対象値列 = InputBox("対象値のある列を入力してください")
列挿入 = MsgBox("列挿入しそこに転記しますか？", vbYesNo)
If 列挿入 = vbYes Then
転記列 = InputBox("挿入したい列を入力してください。例：Ｈ列とI列の間→Ｈ")
Else
転記列 = InputBox("転記する列を入力してください")
End If
If 列挿入 = vbYes Then
Columns(転記列).Insert Shift:=xlToRight
End If
'データは2行目からの事
行 = 2
Do
'対象値列にデータがあるまで繰り返す
n = Cells(行, 1).Value
If n = "" Then Exit Do
'対象列は14文字である事
If Len(n) = 14 Then
Select Case True
'左2字=9X & -が無
Case Left(n, 2) = "9X" And InStr(n, "-") = 0
'3-11で編集
myStr = Left(n, 3) & "-" & Mid(n, 4)
'9字目が-
Case Mid(n, 9, 1) = "-"
'3-5-5で編集
myStr = Left(n, 3) & "-" & Mid(n, 4, 11)
'左1字=9 & -が無
Case Left(n, 1) = "9" And InStr(n, "-") = 0
'5-5-2-2で編集
myStr = Left(n, 5) & "-" & Mid(n, 6, 5) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
'-が無
Case InStr(n, "-") = 0
'3-5-2-2で編集
myStr = Left(n, 3) & "-" & Mid(n, 4, 5) & "-" & Mid(n, 9, 2) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
'いずれにも属さない14文字
Case Else
'編集対象の値を使用する（未編集）
myStr = n
End Select
'編集対象の値が14文字でない
Else
'編集対象の値を使用する（未編集）
myStr = n
End If
Cells(行, 転記列) = myStr
行 = 行 + 1
Loop
End Sub

回答No.4

merlionXX · ベストアンサー

ご質問の部分（さっきのEndの前）しか見ていなかったのですが、
ご提示の
> 行 = 2
> Do
> '対象値列にデータがあるまで繰り返す
> n = Cells(行, 1).Value

だと、いくら対象列を選んでも、これじゃA列のデータしかみてないですよ。
あと、列の挿入位置が違ったようでそれも修正しました。

> また連続操作が出来ません。
意味不明。

Sub ハイフン挿入05()
Dim 対象値列 As Range, 転記列 As Range
Dim myStr As String, n As String
Dim 列挿入 As Integer
Dim 行 As Long, c(1) As Long

On Error Resume Next
Set 対象値列 = Application.InputBox("対象値のある列をマウスで選択してください", "必ず選択", Type:=8)
On Error GoTo 0
If 対象値列 Is Nothing Then
MsgBox "きゃんせる", , "ヾ(￣□￣； )ノ"
Exit Sub
End If
c(0) = 対象値列.Column
列挿入 = MsgBox("列挿入し、そこに転記しますか？", vbYesNo + vbQuestion, "（＾∇＾）？")

line01:

If 列挿入 = vbYes Then
On Error Resume Next
Set 転記列 = Application.InputBox("挿入したい列の次の列をマウスで選択してください。" & _
vbNewLine & "例：Ｈ列とI列の間→I列を選択", "必ず選択", Type:=8)
On Error GoTo 0
If 転記列 Is Nothing Then
MsgBox "きゃんせる", , "ヾ(￣□￣； )ノ"
Exit Sub
End If

If 転記列.Column <= c(0) Then
MsgBox "対象列がずれます。" & 対象値列.Address(0, 0) & "より右を選択してください。", vbCritical, "Σ（￣ロ￣lll) "
GoTo line01
End If
Else
On Error Resume Next
Set 転記列 = Application.InputBox("転記する列をマウスで選択してください。", "必ず選択", Type:=8)
On Error GoTo 0
If 転記列 Is Nothing Then
MsgBox "きゃんせる", , "ヾ(￣□￣； )ノ"
Exit Sub
End If

If 転記列.Column = c(0) Then
MsgBox "対象列の元の値が削除されてしまいます。" & 対象値列.Address(0, 0) & "以外を選択してください。", vbCritical, "Σ（￣ロ￣lll)"
GoTo line01
End If
End If

c(1) = 転記列.Column
If 列挿入 = vbYes Then
Columns(c(1)).Insert Shift:=xlToRight
End If

行 = 2
Do
n = Cells(行, c(0)).Value
If n = "" Then Exit Do
If Len(n) = 14 Then
Select Case True
Case Left(n, 2) = "9X" And InStr(n, "-") = 0
myStr = Left(n, 3) & "-" & Mid(n, 4)
Case Mid(n, 9, 1) = "-"
myStr = Left(n, 3) & "-" & Mid(n, 4, 11)
Case Left(n, 1) = "9" And InStr(n, "-") = 0
myStr = Left(n, 5) & "-" & Mid(n, 6, 5) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case InStr(n, "-") = 0
myStr = Left(n, 3) & "-" & Mid(n, 4, 5) & "-" & Mid(n, 9, 2) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case Else
myStr = n
End Select
Else
myStr = n
End If
Cells(行, c(1)) = myStr
行 = 行 + 1
Loop
End Sub

お礼

＞だと、いくら対象列を選んでも、これじゃA列のデータしかみてないですよ。

確かにそうです。申し訳ありません。m(__)m
意地悪テストでの誤動作はこれが原因でした。

＞＞ また連続操作が出来ません。
＞意味不明。

これも上記が原因でした。忘れてください。m(__)m

05は、
全ての条件において完璧でした。

どうもありがとうございました。

回答No.5

jcctaira

gx9wxさん　こんにちは。
正直このスペースでの回答を厳しいですが、入力の部分だけを対応してみました。
※列の入力チェックは（１）だけではなく（２）（３）も必要だと思います。
※（２）のエラーメッセージ（「対象列がずれます。●●以外を…）も違うと思いますが…。
※InputBoxで「キャンセル」ボタンの対応はしていません。
下記のサンプルをベースに、細かな所はgx9wxさんで修正してください。　

Sub ハイフン挿入02()
　Const 対象列mess = "対象値のある列を入力してください"
　Const 列挿入mess = "列挿入しそこに転記しますか？"
　Const 転記列mess = "転記する列を入力してください"
　Const 転記挿入mess = "挿入したい列を入力してください。例：Ｈ列とI列の間→Ｈ"
　Const 転記列Emess = "対象列の元の値が削除されてしまいます。@列以外を入力してください。再入力しますか？"
　Const 転記挿入Emess = "対象列がずれます。@列以降を入力してください。再入力しますか？"
　Do
　　If 列入力(対象列mess, 対象値列, 対象値列NO) = False Then Exit Sub
　　列挿入 = MsgBox(列挿入mess, vbYesNo)
　　If 列挿入 = vbYes Then
　　　If 列入力(転記挿入mess, 転記列, 転記列NO) = False Then Exit Sub
　　　If 転記列NO <= 対象値列NO Then
　　　　If MsgBox(Format(UCase(対象値列), 転記挿入Emess), vbYesNo) = vbNo Then Exit Sub
　　　Else
　　　　Exit Do
　　　End If
　　Else
　　　If 列入力(転記列mess, 転記列, 転記列NO) = False Then Exit Sub
　　　If 転記列NO = 対象値列NO Then
　　　　If MsgBox(Format(UCase(対象値列), 転記列Emess), vbYesNo) = vbNo Then Exit Sub
　　　Else
　　　　Exit Do
　　　End If
　　End If
　Loop
　：
　：
End Sub

Function 列入力(メッセージ, 列番号, 列番号NO) As Boolean
　On Error Resume Next
　Do
　　列入力 = True
　　列番号 = UCase(InputBox(メッセージ))
　　Err.Clear
　　列番号NO = Cells(1, 列番号).Column
　　If Err.Number = 0 Then Exit Function
　　列入力 = False
　　If MsgBox("入力値が違います。A～IV　のいずれかを入力してください。再入力しますか？", vbYesNo) = vbNo Then Exit Function
　Loop
End Function

お礼

Function
はまだまったく理解していない為、

＞細かな所はgx9wxさんで修正してください。　

とても修正が出来ません。申し訳ありません。

また列挿入がされない為
Columns(転記列).Insert Shift:=xlToRight
をどこかに入れるのでは？と思うのですが
それもわかりません。

お時間をとっていただきありがとうございました。

回答No.3

merlionXX

> Endが怪しいと思い、
> 削除したら思ったように動きました。

ごめんごめん、お尋ねになったこととは無関係な部分を止めてました。
消すのをわすれちゃった。
（*/o＼*）恥ずかしい・・・。

お礼

ありがとうございます。

03も04も

列挿入→No
で列を指定すると

どこかの列を指定列にコピーするみたいです。

で不思議なのはその処理が終了した状態でそのシートで
02を走らせると、02も03,04と同じ動きになってしまう事です。

ちょっと混乱しています。

補足

すいません。
データの問題のようです。

Ａ～Ｆ列にデータがあって
手動で
A列に挿入し
Ａ列がＢ列になった状態で
マクロを走らせると、おかしな動きになります。

通常はこのような事はありませんので
私の操作ミスです。

お騒がせしました。

回答No.2

merlionXX

すみません、さきほどのコードはキャンセル処理がいいかげんでした。
修正しましたが、文字数制限に引っかかったので、コメントとインデントはすべて消しました。
あしからず。

Sub ハイフン挿入04()
Dim 対象値列 As Range, 転記列 As Range
Dim myStr As String, n As String
Dim 列挿入 As Integer
Dim 行 As Long, c(1) As Long

On Error Resume Next
Set 対象値列 = Application.InputBox("対象値のある列をマウスで選択してください", "必ず選択", Type:=8)
On Error GoTo 0
If 対象値列 Is Nothing Then
MsgBox "きゃんせる", , "ヾ(￣□￣； )ノ"
Exit Sub
End If
c(0) = 対象値列.Column
列挿入 = MsgBox("列挿入しそこに転記しますか？", vbYesNo + vbQuestion, "（＾∇＾）？")

line01:

If 列挿入 = vbYes Then
On Error Resume Next
Set 転記列 = Application.InputBox("挿入したい列の前列をマウスで選択してください。" & _
vbNewLine & "例：Ｈ列とI列の間→Ｈを選択", "必ず選択", Type:=8)
On Error GoTo 0
If 転記列 Is Nothing Then
MsgBox "きゃんせる", , "ヾ(￣□￣； )ノ"
Exit Sub
End If

If 転記列.Column <= c(0) Then
MsgBox "対象列がずれます。" & 対象値列.Address(0, 0) & "より右を選択してください。", vbCritical, "Σ（￣ロ￣lll) "
GoTo line01
End If
Else
On Error Resume Next
Set 転記列 = Application.InputBox("転記する列をマウスで選択してください。", "必ず選択", Type:=8)
On Error GoTo 0
If 転記列 Is Nothing Then
MsgBox "きゃんせる", , "ヾ(￣□￣； )ノ"
Exit Sub
End If

If 転記列.Column = c(0) Then
MsgBox "対象列の元の値が削除されてしまいます。" & 対象値列.Address(0, 0) & "以外を選択してください。", vbCritical, "Σ（￣ロ￣lll)"
GoTo line01
End If
End If
c(1) = 転記列.Column
If 列挿入 = vbYes Then
Columns(c(1)).Insert Shift:=xlToRight
End If

End
行 = 2
Do
n = Cells(行, 1).Value
If n = "" Then Exit Do
If Len(n) = 14 Then
Select Case True
Case Left(n, 2) = "9X" And InStr(n, "-") = 0
myStr = Left(n, 3) & "-" & Mid(n, 4)
Case Mid(n, 9, 1) = "-"
myStr = Left(n, 3) & "-" & Mid(n, 4, 11)
Case Left(n, 1) = "9" And InStr(n, "-") = 0
myStr = Left(n, 5) & "-" & Mid(n, 6, 5) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case InStr(n, "-") = 0
myStr = Left(n, 3) & "-" & Mid(n, 4, 5) & "-" & Mid(n, 9, 2) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2)
Case Else
myStr = n
End Select
Else
myStr = n
End If
Cells(行, c(1)) = myStr
行 = 行 + 1
Loop
End Sub

お礼

ありがとうございます。
03同様に

End If

End
行 = 2
Do

の
Endを削除したら動きました。

・最初対象列をＣ列にします。
・挿入→No
・転記列選択
　・Ｃ列→ERR（正）
　・Ｄ列選択→編集はされずどこかの列の値をコピーします（NG）

また連続操作が出来ません。

・対象列をＢ列
・挿入選択
・Ｄ列→成功
・そのシートで再マクロ
・対象列をＢ列
・挿入選択
・Ｆ列→どこかの列の値がコピーされます。

これは03も同じでした。

連続動作ですが02は大丈夫でした。

私の操作が違っているのかも知れません。
もう少しやってみます。

回答No.1

merlionXX

こんにちは。

> （１）
> インプットBOX－１，２，３はエクセルの列の入力なので
> Ａ～ＩＶ以外の入力はエラーとして

ならば、最初からRangeしか入らないようにして、マウスで選択させたら？
こんな感じ？

Sub ハイフン挿入03()
　　Dim 対象値列 As Range, 転記列 As Range
　　Dim myStr As String, n As String
　　Dim 列挿入 As Integer
　　Dim 行 As Long, c(1) As Long

　　Set 対象値列 = Application.InputBox("対象値のある列をマウスで選択してください", "必ず選択", Type:=8)
　　If 対象値列 Is Nothing Then MsgBox "きゃんせる"
　　c(0) = 対象値列.Column
　　列挿入 = MsgBox("列挿入しそこに転記しますか？", vbYesNo + vbQuestion, "（＾∇＾）？")

line01:

　　If 列挿入 = vbYes Then
　　　　Set 転記列 = Application.InputBox("挿入したい列の前列をマウスで選択してください。" & _
　　　　vbNewLine & "例：Ｈ列とI列の間→Ｈを選択", "必ず選択", Type:=8)
　　　　If 転記列.Column <= c(0) Then
　　　　　　MsgBox "対象列がずれます。" & 対象値列.Address(0, 0) & "より右を選択してください。", vbCritical, "Σ（￣ロ￣lll) "
　　　　　　GoTo line01
　　　　End If
　　Else
　　　　Set 転記列 = Application.InputBox("転記する列をマウスで選択してください。", "必ず選択", Type:=8)
　　　　If 転記列.Column = c(0) Then
　　　　　　MsgBox "対象列の元の値が削除されてしまいます。" & 対象値列.Address(0, 0) & "以外を選択してください。", vbCritical, "Σ（￣ロ￣lll)"
　　　　　　GoTo line01
　　　　End If
　　End If
　　c(1) = 転記列.Column
　　If 列挿入 = vbYes Then
　　　　Columns(c(1)).Insert Shift:=xlToRight
　　End If

　　End
　　行 = 2
　　Do
　　　　n = Cells(行, 1).Value
　　　　If n = "" Then Exit Do
　　　　If Len(n) = 14 Then '対象列は14文字である事
　　　　　　Select Case True
　　　　　　　　Case Left(n, 2) = "9X" And InStr(n, "-") = 0 '左2字=9X & -が無
　　　　　　　　myStr = Left(n, 3) & "-" & Mid(n, 4) '3-11で編集
　　　　　　　　Case Mid(n, 9, 1) = "-" '9字目が-
　　　　　　　　myStr = Left(n, 3) & "-" & Mid(n, 4, 11) '3-5-5で編集
　　　　　　　　Case Left(n, 1) = "9" And InStr(n, "-") = 0 '左1字=9 & -が無
　　　　　　　　myStr = Left(n, 5) & "-" & Mid(n, 6, 5) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2) '5-5-2-2で編集
　　　　　　　　Case InStr(n, "-") = 0 '-が無
　　　　　　　　myStr = Left(n, 3) & "-" & Mid(n, 4, 5) & "-" & Mid(n, 9, 2) & "-" & Mid(n, 11, 2) & "-" & Mid(n, 13, 2) '3-5-2-2で編集
　　　　　　　　Case Else 'いずれにも属さない14文字
　　　　　　　　myStr = n '編集対象の値を使用する（未編集）
　　　　　　End Select
　　　　Else '編集対象の値が14文字でない
　　　　　　myStr = n '編集対象の値を使用する（未編集）
　　　　End If
　　　　Cells(行, c(1)) = myStr
　　　　行 = 行 + 1
　　Loop
End Sub

お礼

こんにちは。
ありがとうございます。

なかなか回答がつかなかったので
マクロでの対応は無理なのかな？と思いました。

で教えていただいた記述ですが途中で動きませんでした。

End If

　　End
　　行 = 2
　　Do

この行=2の前の
Endが怪しいと思い、
削除したら思ったように動きました。