Results of 1 - 1 of about 37672 for IF (0.007 sec.)
- [[20110614101232]]
- #score: 1591
- @digest: 76dbcfce123bbb79cb3f42ef5057b6e5
- @id: 54893
- @mdate: 2011-06-14T06:17:31Z
- @size: 9977
- @type: text/plain
- #keywords: 値移 (55646), 先", (25309), 行?" (20030), 動() (19381), 行", (18664), toppo (18278), 動先 (18225), unmerge (14013), 続行 (13116), mergecells (12060), 合解 (10799), 除時 (9472), 複" (7687), 先範 (6607), nothing (5643), て続 (5536), vbyesno (5507), formula (5349), 移動 (4962), columns (4792), vbyes (4080), selection (4005), resize (3623), 囲: (3509), count (3370), inputbox (3092), 結合 (2815), 解除 (2697), ト用 (2542), intersect (2423), error (2363), temp (2205)
- 『指定範囲2箇所のダブリチェック』（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で重なる範囲のオブジェクトがあるかないかで チェックできます。 （momo） ---- ごちゃ混ぜにしていませんか? 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に入れるとか （momo） ---- > の時などに消えてしまいませんか? 意味が解からないのですが? 何が消えるのでしょう? (seiya) ---- momoさん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さんの質問はそういう内容だと私は認識していたものですから。 と、書いている間に衝突〜 ご理解頂けたようで・・・失礼しました。 （momo） ---- またまた衝突 それだったらこれ? 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)... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201106/20110614101232.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97021 documents and 608149 words.
訪問者：