エクセルのマクロのことで

質問

選択範囲を左右対称形でカット＆ペーストするマクロを作成したいのですが。

F1あ　　　
F2い　　G2う
F3え　　G3お　　H3か

上記でF1：H3を選択して実行すると、InputBoxに貼付け先を指定し、仮にD1を選ぶと以下の結果になります。

　　　　　　　　D1あ
　　　　C2う　D2い　　　　　　
B3か　C3お　D3え　　　　

以下のマクロを作成しましたがうまくいきません。

rc = Selection.Rows.count
cc = Selection.Columns.count

Set pt = Application.InputBox("貼り付け先", "Paste", Type:=8)

For j = 1 To rc

For i = 1 To cc

Selection.Offset(j - 1, i - 1).Cut pt.Offset(j - 1, 1 - i)

Next i

Next j

実行結果ですが。
InputBoxの指定先を基点に左右対称ではなくそのままの向きでカット＆ペーストされます。
また、カット＆ペースト処理のところでエラーになって止まってしまいます。

どこがおかしいのでしょうか？
ご指摘お願いします。

回答No.4

BLUEPIXY · ベストアンサー

＃２で書いたコトに加えて、
Ｃｕｔ メソッドは、変数を破壊的に使用するようです。
rc = Selection.Rows.Count
cc = Selection.Columns.Count

Set pt = Application.InputBox("貼り付け先", "Paste", Type:=8)
d = pt.Address
s = Selection.Cells(1, 1).Address
For j = 1 To rc
For i = 1 To cc
Set pt = Range(d)
Set x = Range(s)
If Not (x.Offset(j - 1, i - 1) = Empty) Then
x.Offset(j - 1, i - 1).Cut pt.Offset(j - 1, 1 - i)
End If
Next i
Next j
のように修正したところ動作できました。

お礼

ありがとうございます。
成功しました。

回答No.3

ipsum11

For文を下記のように変更しました。
「Set pt = ～」までは変更していません。

prc = pt.Row
pcc = pt.Column
For j = Selection.Row To Selection.Row + rc - 1

k = 0
For i = Selection.Column To Selection.Column + cc - 1
Cells(j, i).Cut Cells(prc + l, pcc - k)
k = k + 1
Next i

l = l + 1
Next j

お礼

ありがとうございます。
成功しました。

回答No.2

BLUEPIXY

Selection.Offset(j - 1, i - 1) は、オフセットで指定した１つのセルを指しているのではありません。
例えば
Selection が F1:H3 の時
Selection.Offset(1, 1) は、G2:I4 になります。

お礼

ありがとうございます。
目から鱗が落ちたような思いです。

が、"cc = Selection.Columns.count"の後ろに、"ActiveCell.Select"を追記して複数セル選択を解除して試してみましたが、うまくいきませんでした。

回答No.1

marbin

単純にシート1の選択セルをシート2のA1から
左右逆に転記するのは↓のようになります。

今回は貼り付け先指定ですので改造が必要です。

Sub gyaku()
Dim i As Long
Dim j As Long
Dim k As Long
Dim r As Range
Dim tenkirow As Long
Dim tenkicol As Long
Set r = Selection
For i = r.Resize(1).Row To r.Resize(1).Row + r.Rows.Count - 1
k = k + 1
For j = r.Columns.Count + r.Resize(, 1).Column - 1 To r.Resize(, 1).Column Step -1
tenkirow = k
tenkicol = r.Columns.Count + r.Resize(, 1).Column - j
Worksheets(2).Cells(tenkirow, tenkicol).Value = Worksheets(1).Cells(i, j).Value
Next j
Next i
End Sub

お礼

ありがとうございます。