[[20110614101232]]　『指定範囲２箇所のダブリチェック』（toppo）　ページの最後に飛ぶ

『指定範囲２箇所のダブリチェック』（toppo）

 選択したセル範囲の値だけを指定セルに移動する物です。（書式を除く）
 ここで教えて頂いた物に少し手を加えました。(移動先のセルが結合されていた時の処理)教えて頂きたいのは、移動元と、移動先のセル範囲がダブっていた時には中止したいのです。下のコードではダブっていても元の領域を全て消去します。

 Sub 値移動()
    Dim r As Range
    On Error Resume Next
    If Selection.Areas.Count > 1 Then
            MsgBox "複数の島選択は出来ません。"
        Else
            Set r = Application.InputBox("移動先", Type:=8)
            On Error GoTo 0
            If r Is Nothing Then Exit Sub
            If r.Cells(1).Cells.MergeCells = True Then
                If MsgBox("指定セルは結合されています。" & vbCrLf & _
                        "結合解除して移動して良いですか？", vbQuestion + vbOKCancel + vbDefaultButton2, "確認") = vbCancel Then
                        Set r = Nothing
                        Exit Sub
                End If
                r.Cells(1).Cells.MergeCells = False '結合解除
            End If
            With Selection
                r.Cells(1).Resize(.Rows.Count, .Columns.Count).Formula = .Formula
                .ClearContents
            End With
            Set r = Nothing
    End If
 End Sub

 選択範囲　：Selection
 移動先範囲：r.Resize(Selection.Rows.Count,Selection.Columns.Count)

 ですよね？

 比較はApplication.Intersectで重なる範囲のオブジェクトがあるかないかで
 チェックできます。

 （ｍｏｍｏ）

 ごちゃ混ぜにしていませんか？

 Sub 値移動()
    Dim r As Range, c As range
    On Error Resume Next
    Set r = Application.InputBox("移動先", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    If Not Intersect(r, Selection.Cells) Is Nothing Then
        Set r = Nothing
        Exit Sub
    End If
    With Selection
        For Each c In r.Cells(1).Resize(.Rows.Count, .Columns.Count)
            If c.MergeCells Then
               If vbYes <> MsgBox("結合を解除して続行", vbYesNo) Then
                    Set r = Nothing
                    Exit Sub
                Else
                    r.Resize(.Rows.Count, .Columns.Count).UnMerge
                    Exit For
                End If
            End If
        Next
        r.Cells(1).Resize(.Rows.Count, .Columns.Count).Formula = .Formula
        .ClearContents
    End With
    Set r = Nothing
 End Sub

 (seiya)

 >seiyaさん
 それだと

 Sub 値移動()
    With Range("D5:F7") 'テスト用
      .Value = "TEST"
      .Select
    End With            'テスト用　ここまで

    'On Error Resume Next
    'Set r = Application.InputBox("移動先", Type:=8)
    'On Error GoTo 0

    Set r = Range("C4") 'テスト用

    If r Is Nothing Then Exit Sub

    ～～～以下省略～～～

 の時などに消えてしまいませんか？
 >移動先範囲：r.Resize(Selection.Rows.Count,Selection.Columns.Count)
 と比較した方が良いと思うのですが・・・

 それか値を変数に持って、ClearContentsしてからValueに入れるとか
 （ｍｏｍｏ）

 > の時などに消えてしまいませんか？
 意味が解からないのですが？

 何が消えるのでしょう？
 (seiya)

ｍｏｍｏさんseiyaさんありがとうございます。
こんな感じで出来ました。
移動先のデータと前のデータが重なった部分が消えるのですが。
今回これでいいと思います。

 Sub 値移動()
    Dim r As Range, c As Range
    On Error Resume Next
    Set r = Application.InputBox("移動先", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    If Not Intersect(r, Selection.Cells) Is Nothing Then
        Set r = Nothing
        Exit Sub
    End If
    If Not Intersect(Selection.Cells, r.Cells(1).Resize(Selection.Rows.Count, Selection.Columns.Count)) Is Nothing Then
        MsgBox "元と先でセルが重なっているので中止！"
        Exit Sub
    End If
    With Selection
        For Each c In r.Cells(1).Resize(.Rows.Count, .Columns.Count)
            If c.MergeCells Then
               If vbYes <> MsgBox("結合を解除して続行", vbYesNo) Then
                    Set r = Nothing
                    Exit Sub
                Else
                    r.Resize(.Rows.Count, .Columns.Count).UnMerge
                    Exit For
                End If
            End If
        Next
        r.Cells(1).Resize(.Rows.Count, .Columns.Count).Formula = .Formula
        .ClearContents
    End With
    Set r = Nothing
 End Sub
（toppo）

 衝突
 あーーー
 意味が解りました。

 Sub 値移動()
    Dim r As Range, c As Range
    On Error Resume Next
    Set r = Application.InputBox("移動先", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    With Selection
        If Not Intersect(r.Resize(.Rows.Count, .Columns.Count), .Cells) Is Nothing Then
            Set r = Nothing
            MsgBox "範囲が重複", vbCritical
            Exit Sub
        End If
        For Each c In r.Cells(1).Resize(.Rows.Count, .Columns.Count)
            If c.MergeCells Then
               If vbYes <> MsgBox("結合を解除して続行", vbYesNo) Then
                    Set r = Nothing
                    Exit Sub
                Else
                    r.Resize(.Rows.Count, .Columns.Count).UnMerge
                    Exit For
                End If
            End If
        Next
        r.Cells(1).Resize(.Rows.Count, .Columns.Count).Formula = .Formula
        .ClearContents
    End With
    Set r = Nothing
 End Sub
 (seiya)

 >何が消えるのでしょう？
 移動先が、必ず範囲なら良いですが、
 左上の単セルを指定した場合にはResizeしないと
 Selectionの範囲と移動先の範囲が重なっている時に
 移動先.Formula=Selection.Fomula
 の後にSelection.Clearcontentsしているのでセルの内容は消えますよね？
 toppoさんの質問はそういう内容だと私は認識していたものですから。

 と、書いている間に衝突～
 ご理解頂けたようで・・・失礼しました。
 （ｍｏｍｏ）

 またまた衝突

 それだったらこれ？

 Sub 値移動()
    Dim r As Range, c As Range, temp
    On Error Resume Next
    Set r = Application.InputBox("移動先", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    With Selection
        If Not Intersect(r.Resize(.Rows.Count, .Columns.Count), .Cells) Is Nothing Then
            If vbYes <> MsgBox("範囲が重複" & vbLf & "続行?", vbYesNo) Then
                Set r = Nothing
                Exit Sub
            End If
        End If
        For Each c In r.Cells(1).Resize(.Rows.Count, .Columns.Count)
            If c.MergeCells Then
               If vbYes <> MsgBox("結合を解除して続行", vbYesNo) Then
                    Set r = Nothing
                    Exit Sub
                End If
            End If
        Next
        temp = .Formula
        .ClearContents
        r.Cells(1).Resize(.Rows.Count, .Columns.Count).Formula = temp
    End With
    Set r = Nothing
 End Sub
 (seiya)

 seiyaさん重複時の処理大変有り難う御座います。それは最初っから出来ないだろうと
 思っていた物でした。すごいです。
 異なるシート間でも出来ないでしょうか。今更となるでしょうか。
 これが出来れば、Excel本体の機能よりすごいと思うのですが。
 すみませんが、宜しく処理お願い申し上げます。

 結合解除時に以下が必要だと思います。以前ありましたので。
 Else
     r.Resize(.Rows.Count, .Columns.Count).UnMerge
     Exit For

 Sub 値移動()
    Dim r As Range, c As Range, temp
    On Error Resume Next
    Set r = Application.InputBox("移動先", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    With Selection
        If Not Intersect(r.Resize(.Rows.Count, .Columns.Count), .Cells) Is Nothing Then
            If vbYes <> MsgBox("範囲が重複" & vbLf & "続行?", vbYesNo) Then
                Set r = Nothing
                Exit Sub
            End If
        End If
        For Each c In r.Cells(1).Resize(.Rows.Count, .Columns.Count)
            If c.MergeCells Then
               If vbYes <> MsgBox("結合を解除して続行", vbYesNo) Then
                        Set r = Nothing
                        Exit Sub
                    Else
                        r.Resize(.Rows.Count, .Columns.Count).UnMerge
                        Exit For
                End If
            End If
        Next
        temp = .Formula
        .ClearContents
        r.Cells(1).Resize(.Rows.Count, .Columns.Count).Formula = temp
    End With
    Set r = Nothing
 End Sub
(toppo)

 > 結合解除時に以下が必要だと思います。以前ありましたので
 一度変数に格納したので、必要ありません。
 訂正：必要でしたね...

 Sub 値移動()
    Dim r As Range, c As Range, temp
    On Error Resume Next
    Set r = Application.InputBox("移動先", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    With Selection
        If .Parent Is r.Parent Then
            If Not Intersect(r.Resize(.Rows.Count, .Columns.Count), .Cells) Is Nothing Then
                If vbYes <> MsgBox("範囲が重複" & vbLf & "続行?", vbYesNo) Then
                    Set r = Nothing
                    Exit Sub
                End If
            End If
        End If
        For Each c In r.Cells(1).Resize(.Rows.Count, .Columns.Count)
            If c.MergeCells Then
               If vbYes <> MsgBox("結合を解除して続行", vbYesNo) Then
                        Set r = Nothing
                        Exit Sub
                    Else
                        r.Resize(.Rows.Count, .Columns.Count).UnMerge
                        Exit For
                End If
            End If
        Next
        temp = .Formula
        .ClearContents
        r.Cells(1).Resize(.Rows.Count, .Columns.Count).Formula = temp
    End With
    Set r = Nothing
 End Sub
 (seiya)

 seiyaさんすみません。
 ＞ 結合解除時に以下が必要だと思います。以前ありましたので。
 これは間違いだった様です、動作が変だと勘違いして見たみたいです。
 改良して頂いた物、いろいろ試してみましたが、okでした。
 是非Excelの標準機能として欲しいと思うのですが、今までなかった！
 大変助かりました。
 (toppo)

コメント返信：

[ 一覧(最新更新順) ]

[[20110614101232]] 『指定範囲２箇所のダブリチェック』（toppo） ページの最後に飛ぶ

[[20110614101232]]　『指定範囲２箇所のダブリチェック』（toppo）　ページの最後に飛ぶ