エクセルで、コピーに関するマクロ

質問

コピー対象は、例えば、C5に"お"、D5に"は"、E5に"よ"、F5に"う"という感じで、一つのセルに一文字ずつ横に連なるように入力されています。
貼り付ける場所は、例えば、起点をB8にすると、B8に"お"、C9に"は"、D10に"よ"、E11に"う"と、斜め下に連なる形になります。

コピー対象の起点となるセルは毎回違いますが、常に起点と同じ行に一つのセルに一文字ずつ入力されている状態になっており、どこからどこまでをコピー対象にするかは毎回指定することになります。
コピー対象の文字列を構成する個々のセルの中に、空欄のセルが含まれることはありません。また、コピー対象を構成するセルの最後のセルの右隣のセルは、必ず空欄になります。

貼り付ける場所は毎回違います。起点となるセルを指定すると、そのセルから斜め下に連なる形で貼り付けられます。

上記のことができるマクロを教えてもらいたいのですが。

回答No.1

masa_019 · ベストアンサー

以下のコードを標準モジュールに貼り付けて実行します。
コピー対象の起点と、貼り付けの起点をInputBoxで
指定すると、ご希望の形で文字が貼り付くと思います。

InputBoxをキャンセルした時などのエラー処理は省略しています。

Sub test()
Dim copybase As Range
Dim pastebase As Range
Dim i As Integer

Set copybase = Application.InputBox(prompt:="コピーの起点を指定", Type:=8)
Set pastebase = Application.InputBox(prompt:="貼り付ける起点を指定", Type:=8)

For i = 0 To copybase.End(xlToRight).Column - copybase.Column
copybase.Offset(, i).Copy pastebase.Offset(i, i)
Next
Set copybase = Nothing
Set pastebase = Nothing
End Sub

お礼

ご回答ありがとうございました。
大変参考になりました。

回答No.4

Gody

既に様々な方が回答されているようですが、私も作ってみました。
普通のコピーと同じ感覚で使えるようにしたかったので、一時的なシートを作成して、そこへペーストした後、貼りなおしていく感じになっています。その点をご了承の上でお願いします。
また、一回ペーストするとコピー範囲はクリアされます。続けて使用される場合はコピーしなおしてください。
まず、標準モジュールを新しく作って以下のコードを貼り付けてしてください。
-----------------------------------
Sub SkewCopy()

Dim n As Long
Dim i As Variant
Dim CopyRng As Range
Dim BaseCell As Range
Dim TargetSheet As Worksheet
Dim TempSheet As Worksheet

If Application.CutCopyMode = False Then: Exit Sub
Application.ScreenUpdating = False

Set TargetSheet = ActiveSheet
Set BaseCell = ActiveCell

' 一時的にシートを作成して
Set TempSheet = Sheets.Add
With TempSheet
.Cells(1).PasteSpecial
End With
Set CopyRng = Selection

' メイン処理。斜めに貼り直す
TargetSheet.Activate
With BaseCell
For Each i In CopyRng
i.Copy Destination:=.Offset(n, n)
n = n + 1
Next i
End With

' 一時シート削除
With Application
.DisplayAlerts = False
TempSheet.Delete
.DisplayAlerts = True
.CutCopyMode = False
.ScreenUpdating = True
End With

' オブジェクト変数の開放
Set TempSheet = Nothing
Set TargetSheet = Nothing: Set CopyRng = Nothing

End Sub
-----------------------------------

使い方
(1) 通常の方法で範囲をコピー。
(2) 起点を選択。
(3) VBAのエディタ画面のイミディエイトウィンドウ（Ctrl+G）に「SkewCopy」といれ、Enter。（もしくは自分でボタンに登録して使用）

普通に ツール→マクロ→マクロ から実行させると、どうやらコピー範囲がクリアされてしまう模様です。
ご自身でこのSkewCopyプロシージャをボタンから起動できるようにすれば、使い勝手は非常によくなります。
ツールバーへボタンを追加し、マクロを登録する方法については参考URLを参照願います。
なお、当方で一応の動作確認はしました。

以上、長々と失礼しました。参考になれば幸いです。

参考URL：

http://www.harapan.co.jp/honyaku/Macro_Bunko/bunk0104.htm

お礼

ご回答ありがとうございました。
大変参考になりました。

回答No.3

BLUEPIXY

コピー元になる範囲を選んでからマクロを起動します。
マクロを起動すると、貼り付け先基点を指定するようにダイアログがでるので、貼り付け先を指定します。
----------------------------------------------------------------
Public Sub Sample()
Dim r As Range, x As Range
Dim i
Set r = Application.InputBox("貼り付け先を指定してください", "貼り付け先セル指定", , , , , , 8)
i = 0
For Each x In Selection
r.Offset(i, i).Value = x.Value
i = i + 1
Next
End Sub

お礼

ご回答ありがとうございました。
大変参考になりました。

回答No.2

imogasi

先日も同じような質問をしてた人ですね。
どういう使い道があるのかわからないが、お遊びでやってみました。
いろんな場面に耐えられるか判りませんが。
標準モジュールに
Public f(10)
１０は最多セル数を１０と仮定。
ーーー
シートに１つコマンドボタンを貼り付ける。
そのシートのコマンドボタンのクリックイベントに
Private Sub CommandButton1_Click()
For i = 1 To 10
f(i) = ""
Next i
'MsgBox Application.CutCopyMode
If Application.CutCopyMode = xlCopy Then
i = 1
Dim cl
For Each cl In Selection
f(i) = cl
i = i + 1
Next
'For j = 1 To i - 1
'MsgBox f(j)
'Next j
End If
End Sub
を作る。
ーーーー
シートのシートモジュールに
ダブルクリックイベントに
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
For i = 1 To 10
If f(i) = "" Then Exit For
Target.Offset(i - 1, i - 1) = f(i)
Next i
End Sub
を作る。
ーーーーー
操作
（A)範囲指定し、編集ーコピー
（B)コマンドボタンをクリック
（C)貼り付け先の基点のセルでダブルクリックする。
（D)別場所で（C)を行うと、何箇所でも同じ効果が続く
（E)（D)を解除するには、セル選択をなしにして、コマンドボタンを
クリックするとよい。次からダブルクリックしても効果は出ない。
少数テストしたという意味で「自身あり」であって、他のダブルクリックとの競合関係等は判らない。

お礼

ご回答ありがとうございました。
大変参考になりました。

＞ 先日も同じような質問をしてた人ですね。

そうです。
その節はお世話になりました。