【最大10000ポイント】当たる!!質問投稿キャンペーン!

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

仕様と記述

1.インプットBOX-1
  「対象値のある列を入力してください」
  入力例:G
↓↓
2.メッセージボックス
  「列挿入しそこに転記しますか?」
  YES/NO 選択
↓↓
3.YESの場合
  インプットBOX-2
  「挿入したい列を入力してください。例:H列とI列の間→H」
  入力例:H

  NOの場合
  インプットBOX-3
  「転記する列を入力してください」
  入力例:J

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

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

(1)
インプットBOX-1,2,3はエクセルの列の入力なので
A~IV以外の入力はエラーとして
「入力値が違います。A~IV のいずれかを入力してください。再入力しますか?」
でOKをクリックすると再入力可能に

(2)
インプットBOX-2
インプットBOX-1で入力した値より前の値はエラーとする
「対象列がずれます。●●以外を入力してください。再入力しますか?」
OKをクリックで再入力可能に。

例:インプットBOX-1にCと入力した場合A,B,Cはエラー
  となる。●●の所にその値を表示する。

(3)
インプットBOX-3
インプットBOX-1で入力した値と同じ値の場合はエラーとする。
「対象列の元の値が削除されたてしまいます。●●以外を入力してください。再入力しますか?」
OKをクリックで再入力可能に。

例:インプットBOX-1にCと入力した場合Cはエラーとなる。
  ●●の所にその値を表示する。

(1)(2)(3)の記述を教えてください。お願いします。

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

対象値列 = InputBox("対象値のある列を入力してください")
列挿入 = MsgBox("列挿入しそこに転記しますか?", vbYesNo)
If 列挿入 = vbYes Then
転記列 = InputBox("挿入したい列を入力してください。例:H列とI列の間→H")
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

このQ&Aに関連する最新のQ&A

A 回答 (5件)

ご質問の部分(さっきの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 & "例:H列と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
    • good
    • 0
この回答へのお礼

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

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

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

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

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

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

お礼日時:2010/11/26 17:31

gx9wxさん こんにちは。


正直このスペースでの回答を厳しいですが、入力の部分だけを対応してみました。
※列の入力チェックは(1)だけではなく(2)(3)も必要だと思います。
※(2)のエラーメッセージ(「対象列がずれます。●●以外を…)も違うと思いますが…。
※InputBoxで「キャンセル」ボタンの対応はしていません。
下記のサンプルをベースに、細かな所はgx9wxさんで修正してください。 
 
Sub ハイフン挿入02()
 Const 対象列mess = "対象値のある列を入力してください"
 Const 列挿入mess = "列挿入しそこに転記しますか?"
 Const 転記列mess = "転記する列を入力してください"
 Const 転記挿入mess = "挿入したい列を入力してください。例:H列とI列の間→H"
 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
    • good
    • 0
この回答へのお礼

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

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

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

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

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

お礼日時:2010/11/29 09:52

> Endが怪しいと思い、


> 削除したら思ったように動きました。

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

この回答への補足

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

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

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

お騒がせしました。

補足日時:2010/11/26 16:39
    • good
    • 0
この回答へのお礼

ありがとうございます。

03も04も

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

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

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

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

お礼日時:2010/11/26 16:25

すみません、さきほどのコードはキャンセル処理がいいかげんでした。


修正しましたが、文字数制限に引っかかったので、コメントとインデントはすべて消しました。
あしからず。

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 & "例:H列とI列の間→Hを選択", "必ず選択", 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
    • good
    • 0
この回答へのお礼

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

End If

End
行 = 2
Do


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

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

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

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

これは03も同じでした。

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

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

お礼日時:2010/11/26 16:12

こんにちは。



> (1)
> インプットBOX-1,2,3はエクセルの列の入力なので
> A~IV以外の入力はエラーとして

ならば、最初から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 & "例:H列とI列の間→Hを選択", "必ず選択", 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
    • good
    • 0
この回答へのお礼

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

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

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

End If
  
  End
  行 = 2
  Do

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

お礼日時:2010/11/26 15:40

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング