Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2010)
決まった範囲のセルの値をコピペして、セル単位で削除する方法
投稿日時: 18/04/19 22:45:22
投稿者: 河童TKO

いつも大変お世話になっております。
 
決まった範囲のセルの値をコピペして、セル単位で削除する方法について
教えて下さい。
 
やりたいこと
任意で選択された値を別のセルにコピぺした後、
セル単位で削除したいです。
書式のコピーは必要ありません。
 
  A    B    C    D
1 会員ID 会員名 会員ID 会員名
2   1  会員1
3   2  会員2
4   3  会員3
5   4  会員4
6   5  会員5
 
コピーするコマンドボタンを配置して
クリック時にコピペと削除を実行します。
 
セルB3を選択して、実行すると
セルC2にコピーされてセルが削除されます。
 
  A    B    C    D
1 会員ID 会員名  会員ID 会員名
2    1  会員1   3  会員3
3    2  会員2
4    4  会員4
5    5  会員5
 
 
'値のコピー
Range("C2") = Range("B3")
'業削除
Range("4:4").Delete ' 4 行目を削除
 
わからないこと、
1.任意のセルの設定方法
任意のセルが選択されるので、どのようにコードで
設定すれば良いかわかりません。
 
2.名前の範囲内のセルが選択されているか
たとえばA1からB5の範囲に「活動中の会員」と
名前を付けて、この名前の範囲のセルが選択されている場合に
限りコピペを実行したいです。
 
3.複数のセルが選択されている場合はキャンセルしたい
A2からB2の選択されている場合は実行可能。
A2のみも実行可能。コピーするときはA2とB2の値を取得してコピペ。
A2からB3が選択されている場合は実行不可。
 
複数の質問になりますが、アドバイスよろしくお願いいたします。

回答
投稿日時: 18/04/19 23:33:02
投稿者: WinArrow
投稿者のウェブサイトに移動

複写元セルの選択(人手)

複写先セルの選択(人手)
を一つのプロシジャで行いのですか?
 
 

引用:

1.任意のセルの設定方法
 任意のセルが選択されるので、どのようにコードで
設定すれば良いかわかりません。

この文章は、人手操作とプログラム操作が混在しているので
分かりやすくするために、
箇条書きにしましょう。
 
>任意のセル
なんていう必要はありません。
任意は、人の判断ですから、プログラムとしては
選択されたセル
という認識で十分です。
 
と考えると
選択されているセルの値をコピー
次に、選択されるセルに値貼り付け
という2行で説明ができます。
 
どうですか?シンプルでしょ。
 
このように考えると
人手では
複写元セルの選択と
複写先のセルを
同時に選択することはできませんよね?
 
若し、複写元セルと複写先セルの関係に法則があるならば、
複写先セルは選択させる必要はありませんよね・・・
 
複写元セルと複写先セルの関係に法則がないとするならば、
プログラムで選択を促すことができます。
 
 
Dim motoCELL as Range,sakiCELL as Range
 
Set motoCELL = ActiveCell
Set sakiCELL = Application.InputBox(Prompt:="複写先セルを選択してください。",Type:=8")
sakiCELL.Value = motoCELL.Value
 
エッセンスはこれだけです。
後は、複写元セルと複写先セル各々の最低限のルールを付加すればよいでしょう。
複写元セルは、●列でなければいけない、とか
複写先セルは、□列でなければいけない、とか
 
説明では、B3をC2に複写となっていますが、
A3:B3をC2:D2に複写するのではないでしょうか?
 
 
 
 
行の削除
motoCELL.EntireRow.Delete
となります。
 
 
 

回答
投稿日時: 18/04/19 23:44:58
投稿者: WinArrow
投稿者のウェブサイトに移動

>Set motoCELL = ActiveCell
ここは、選択させるのはA列セルだけにして
Set motoCELL = ActiveCell.Resize(,2)
説いた方がよいかも
 
>Set sakiCELL = Application.InputBox(Prompt:="複写先セルを選択してください。",Type:=8")
ここも、C列セルだけにして、
Set sakiCELL = sakiCELL.Resize(,2)
を追加したほうがよいかも
 
>sakiCELL.Value = motoCELL.Value
ここはそのままでもよい

回答
投稿日時: 18/04/20 11:02:30
投稿者: mattuwan44

>1.任意のセルの設定方法
こういう時は、
Sellection
と表現します。マクロの記録で良く出てきますよね?
 
>2.名前の範囲内のセルが選択されているか
名前の定義されているセルは、
Range("活動中の会員")という感じでRangeプロパティの引数に指定することが出来ます。
で、範囲内かどうかのチェックは、Intersect関数がこの場合は便利です。
参考URL>>
http://officetanaka.net/excel/vba/tips/tips118.htm
 
 
>3.複数のセルが選択されている場合はキャンセルしたい
セル範囲の行数を数えるには、
Sellection.Rows.Count
列数を数えるには、
Sellection.Columns.Count
ですこの返り値を比較して条件分岐をしてみては?
 
4.
↓僕が手動で操作した時のマクロの記録です。
Sub Macro2()
'
' Macro2 Macro
'
 
'
    Range("A4:B4").Select
    Selection.Cut Destination:=Range("C2:D2")
    Range("A1:B6").Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A2:B6")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B11").Select
End Sub
 
コピーじゃなくて切取で操作しました。
元の値があったところは空白になります。
元からID順で並んでいるようなので、
ID並び替えをして、空白セルをセル範囲の下に追いやることで
セルを削除したと同じ結果になると思います。
 
貼りつけた先は書式が元のままなので、
もう一回貼りつけた先の1行下をコピーして書式のみ貼り付けてもいいかなと思いますし、
逆にコピー
値の貼り付け
元のセルクリア
IDで並び替え
 
でもいいし、
クリアじゃなくてセルの削除でもいいと思います。

投稿日時: 18/04/21 04:11:39
投稿者: 河童TKO

WinArrowさん、mattuwan44さん
お返事ありがとうございます。
 
複写元セルの選択は人手で行い
複写先セルの選択はプログラムで自動化したいです。
複写先のセルC2から順番に貼り付けていきたいです。
C2に値があればC3に貼り付けたいです。
そのときの条件で
IF文で空白の時とした場合
どこまで繰り返すかわからないので
IF文は無理だと思っています。
繰り返し処理で
セルが空白のときは貼り付けを行う処理にしたいです。
繰り返しのときの条件の書き方がわかりません。
 
 
そうですね。選択させるのはA列にすればわかりやすいです。
 
 
名前の範囲内のセルが選択と複数のセルが選択されている場合
の処理をためしてみます。
 
  
 
 

回答
投稿日時: 18/04/21 10:16:49
投稿者: WinArrow
投稿者のウェブサイトに移動

引用:
複写先のセルC2から順番に貼り付けていきたいです。
C2に値があればC3に貼り付けたいです。

 
C列を下から検索して、空白セルでないセルの一つ下のセルを取得する方法を紹介します。
 
Set sakiCELL = Range("C" & Rows.Count).End(xlUp).Offset(1)
 
Rows.Count は、シートのMax行です。
End(xlUp)で上方向に空白でないセルを探す
 
 

回答
投稿日時: 18/04/22 14:15:19
投稿者: WinArrow
投稿者のウェブサイトに移動

最初の質問時に

引用:
'業削除
Range("4:4").Delete ' 4 行目を削除
 

というところがあります。
 
 
複写先のセルの取得方法については、
ご理解いただいたと思いますので、
上述に行削除について
行削除してしまうと、
C〜D列に貼り付けたデータも削除されてしまいますよね?
 
手操作で、別シートを選択させるのは負荷が掛かり過ぎる、操作ミスも発生しやすいと思いますが、
プログラムで別シートに複写するならば、人的負荷も操作ミスもないので。
私ならば、別シートに複写しますけど・・・
 
 
 
 

投稿日時: 18/05/17 16:47:47
投稿者: 河童TKO

こんにちは。いつもお世話になっております。
 
WinArrowさん、ありがとうございます。
 
今回は、下記のような処理にしました。
 
1.会員名を1つ選択
2.会員IDと会員名をセット
3.コピー場所を設定(開始行から最終行で空白のセルを探す)
4.値を貼り付け
5.コピー元のデータはセル単位で削除
 
コピー元のデータをセル単位で削除しているので
削除後に空白セルを挿入した方が良いかも。
最終行のセルがずれるので。
そこはまた後から処理を追加しようと思います。
 
Sub ボタン1_Click()
     
    '活動中の会員を選択しているかチェック(会員名のみ選択させる)
    If Application.Intersect(ActiveCell, Range("B2:B" & Rows.Count)) Is Nothing Then
     
        MsgBox "活動中の会員を選択してください。", vbExclamation
 
    Else
 
        '会員名のみ選択
        If Selection.Columns.Count <> 1 Then
            MsgBox "会員名のみ選択してください。", vbExclamation
            Exit Sub
        End If
        '選択は1名のみ
        If Selection.Rows.Count <> 1 Then
            MsgBox "会員名は1名のみ選択してください。", vbExclamation
            Exit Sub
        End If
         
         
        Dim motoCELL1 As Range, sakiCELL1 As Range
        Dim motoCELL2 As Range, sakiCELL2 As Range
         
        '会員名をセット
        Set motoCELL1 = Cells(Selection.Row, Selection.Column)
        '会員IDをセット
        Set motoCELL2 = Cells(Selection.Row, Selection.Column + Selection.Columns.Count - 2)
         
         
        '変数の宣言
         Dim i As Long '行数のカウントアップ
     
        '2行目からスタート
        i = 2
        Do Until Range("D" & i) = "" And Range("D" & i) <> "最終行"
             
            If Range("D" & i).Value = "最終行" Then
                 MsgBox "最終行を超える事はできません。", vbExclamation
                 Exit Sub
            End If
                         
            i = i + 1
     
        Loop
            
        Set sakiCELL1 = Range("D" & i)
        Set sakiCELL2 = Range("C" & i)
         
        '会員名をコピー
        sakiCELL1.Value = motoCELL1.Value
        '会員IDをコピー
        sakiCELL2.Value = motoCELL2.Value
           
        'セル削除(上方向にシフト)
        motoCELL1.Delete Shift:=xlShiftUp
        motoCELL2.Delete Shift:=xlShiftUp
               
    End If
     
End Sub