セルの一部を任意の条件で貼り付けor転記するマクロ(Excel-VBA)

質問

【質問A】2列×12行に収まった数値があり（これらを選択・コピーして）
任意のセルに貼り付ける際、

(1) 行列を入れ替えて
(2) 一行に並べ
(3) セルの背景を黄色に着色して
(4) 値のみ貼り付け

を一気に済ませたいのです。具体的には、

１Ｃ
２Ｄ
３Ｅ
４Ｆ
５Ｇ
６Ｈ
７Ｉ
８Ｊ
９Ｋ
０Ｌ
ＡＭ
ＢＮ　　　　　　・・・という元データを

１２３４５６７８９０ＡＢＣＤＥＦＧＨＩＪＫＬＭＮ

というイメージ（というか順序）にしたいです。ショートカット
キーに、Ctrl+Shift+Vみたいなのを割当てて多用したいです。
さらに欲張ってすみませんが、

【質問B】上記の条件のうち「値のみ貼り付け」るのでなく、番地を参照する式
　（例： =A1、=EF43のような）を埋めるマクロや

【質問C】2列×12行の左上角（上例で言う'１'のセルですね）を選択して
　マクロを実行したら、自動で同じ行の10列右の番地に冒頭の(1)～(4)を
　施すようなマクロも望んでいます。

それぞれ、独立したマクロとして、適材適所に使い分けられると
大変助かるのですが。。。

なお、【A】の(1)(3)(4)までならキーボードマクロを細工して何とかなりました。

Sub macro1()
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
With Selection.Interior
.ColorIndex = 6
End With
End Sub

しかし、(2)はたぶん私が全く理解できない配列を使わなければ
実現しないと推察します。さらに、【B】【C】レベルですと、
もう完全にお手上げ状態です。。。

どうぞ、よろしくお願い致します。

回答No.2

Wendy02 · ベストアンサー

こんにちは。

ある程度、マクロがおわかりになるようなので、細かな説明はいたしませんし、不具合は、なんとか自力で直していただきたいです。ご要望の全てが入っているはずです。
なお、値貼り付けには、ワークシートの行列を超える貼り付けのエラー処理が付けられていますが、それらエラー処理が十分にチェックされたわけではありません。

'<標準モジュール推奨>
'----------------------------------------------
Sub TransposePaste()
　 Dim Rng As Range
　 Dim c As Range
　 Dim Dflg As Boolean
　 Dim SideLength As Integer
　 Dim Ar() As Variant
　 Dim i As Long
　 Dim j As Long
　 Dim Destin As Range
　 ''==================================
　 ''//ユーザーオプション//
　 Const C_DESTIN As Integer = 0 '数字のみ
　 ''10列右　なら、10 を入れる,20行下なら、20 を入れる
　 ''ただし、元のデータを上書きすることは出来ません。
　 ''ユーザー選択の場合は 0 にする
　 Const VALUE_PASTE = True
　 ''値貼り付けは、「True」、式貼り付けは、「False」
　 ''===================================
　 Set Rng = Selection
　 If WorksheetFunction.CountA(Rng) < 2 Then MsgBox "データは２つ以上ないといけません。", 64: Exit Sub
　 If Rng.Count = 1 Then MsgBox "セルは２つ以上ないといけません。", 64: Exit Sub
　 If Rng.Columns.Count > Rng.Rows.Count Then
　　　Dflg = True
　　　SideLength = Rng.Rows.Count
　　　Else
　　　SideLength = Rng.Columns.Count
　 End If
　 ReDim Ar(1 To Rng.Count)
　 For i = 1 To SideLength
　　　If Dflg Then
　　　　 For Each c In Rng.Rows(i).Cells
　　　　　　j = j + 1
　　　　　　If VALUE_PASTE Then
　　　　　　　 Ar(j) = c.Value
　　　　　　　 Else
　　　　　　　 Ar(j) = c.Address(0, 0) '相対参照
　　　　　　'絶対参照の場合は、c.Address となる。
　　　　　　End If
　　　　 Next c
　　　　 Else
　　　　 For Each c In Rng.Columns(i).Cells
　　　　　　j = j + 1
　　　　　　If VALUE_PASTE Then
　　　　　　　 Ar(j) = c.Value
　　　　　　　 Else
　　　　　　　 Ar(j) = c.Address(0, 0)
　　　　　　End If
　　　　 Next c
　　　End If
　 Next i
　 If C_DESTIN = 0 Then
　　　On Error Resume Next
　　　Set Destin = Application.InputBox("貼り付け場所を決めてください。", Type:=8)
　　　On Error GoTo 0
　　　If Err.Number > 0 Then Exit Sub
　　　If Destin Is Nothing Then MsgBox "選択されていません。", 64: Exit Sub
　　　Else
　　　Set Destin = Selection
　 End If

　　If Rng.Count + Destin.Rows.Count + C_DESTIN > 65536 Or _
　　　　Rng.Count + Destin.Columns.Count + C_DESTIN > 256 Then
　　　　MsgBox "ワークシートの領域を越えるために、その貼り付けは出来ません。", 16: Exit Sub
　　End If

　 If VALUE_PASTE Then
　　　s_PasteValue Destin, C_DESTIN, Ar(), Dflg
　　　Else
　　　s_PasteFormula Destin, C_DESTIN, Ar(), Dflg
　 End If
End Sub
Sub s_PasteValue(Destin As Range, Destination As Integer, BaseArray() As Variant, flg As Boolean)
'値貼り付け用サブルーチン

　 If flg Then
　　　With Destin.Cells(1, 1).Offset(Destination).Resize(UBound(BaseArray()))
　　　If Not Intersect(.Cells, Selection) Is Nothing Then GoTo ErrMsg
　　　　 .Value = WorksheetFunction.Transpose(BaseArray())
　　　　 .Interior.ColorIndex = 6 '黄色
　　　End With
　　　Else
　　　With Destin.Cells(1, 1).Offset(, Destination).Resize(, UBound(BaseArray()))
　　　If Not Intersect(.Cells, Selection) Is Nothing Then GoTo ErrMsg
　　　　 .Value = BaseArray()
　　　　 .Interior.ColorIndex = 6 '黄色
　　　End With
　 End If
　 Exit Sub
ErrMsg:
　 MsgBox "データを上書きはできません。" & vbCrLf & "C_DESTIN の定数を調べてください。", 64
　 Set Destin = Nothing
End Sub
Sub s_PasteFormula(Destin As Range, Destination As Integer, BaseArray() As Variant, flg As Boolean)
'式貼り付け用サブルーチン
　 Dim c As Range
　 Dim k As Long
　 Application.ScreenUpdating = False
　 If flg Then
　　　With Destin.Cells(1, 1).Offset(Destination).Resize(UBound(BaseArray()))
　　　If Not Intersect(.Cells, Selection) Is Nothing Then GoTo ErrMsg
　　　　 For Each c In .Cells
　　　　　　k = k + 1
　　　　　　.Cells(k).FormulaLocal = "=" & BaseArray(k)
　　　　　　.Interior.ColorIndex = 6 '黄色
　　　　 Next c
　　　End With
　　　Else
　　　With Destin.Cells(1, 1).Offset(, Destination).Resize(, UBound(BaseArray()))
　　　If Not Intersect(.Cells, Selection) Is Nothing Then GoTo ErrMsg
　　　　 For Each c In .Cells
　　　　　　k = k + 1
　　　　　　.Cells(k).FormulaLocal = "=" & BaseArray(k)
　　　　　　.Interior.ColorIndex = 6 '黄色
　　　　 Next c
　　　End With
　 End If
　 Application.ScreenUpdating = True
　 Exit Sub
ErrMsg:
　 MsgBox "データを上書きはできません。" & vbCrLf & "C_DESTIN の定数を調べてください。", 64
　 Set Destin = Nothing
End Sub

'---------------------------------------------------
なお、1つの質問の中で、あまり数多く要望を盛り込むのは、私としては、あまり望まれない内容です。なるべく、ご自身の使用の範囲内の疑問や問題点が質問の内容であってほしいですね。

お礼

Wendy02さん、いつもお世話になっております。
まずは御礼申し上げますが、鳥肌が立つほど完璧で、本当に
感謝に耐えません。
あまりにも処理対象データ数が多すぎて途方にくれていたところでした。

素人考えでは、「全てを組み込んでオプション化」という
'発想'がなかったので、こういうこともできるのかと驚くばかりでした。

いくつも要望を出してしまったこと、失礼しました。
以後、要点を整理して質問するよう、注意いたします。

正直、膨大なExcel帳票から必要な部分（←法則性なし）を
目で探しながら整形するのに、どうするのが効率的か
考えているうち、ケースによって質問A、B、Cを使い分けるのが
いいかと、思いついた次第です。

しかし、入念に仕様をアレンジいただけたおかげで、
「セルを選択してマクロショートカットキーからを実行するだけで
n列右に、ポコポコとデータセット化される」という設定が大変
気に入りました。

なんとか自分でコードを作れるよう、努力したいと思います。
今後ともよろしくお願い致します。

回答No.3

imogasi

＃１です。お礼に関して
＞実行すると、Msgboxに「1」と表示されて何も起こりません・・
私は質問の例
A1:B１２に下記データを置いて、私のコードを実行し、一応動くことを確認しています。
１Ｃ
２Ｄ
３Ｅ
４Ｆ
５Ｇ
６Ｈ
７Ｉ
８Ｊ
９Ｋ
０Ｌ
ＡＭ
ＢＮ
「Msgboxに「1」と表示され」るのは、A列にデータがないのではないでしょうか。
たとえ何かの間違いが私にあるとしても、それを修正して、アイデアだけでも生かしてもらえないと、と思ってしまいますが、私の勝手かも。
まあ心配は本当になって、残念ながら、本件は私には、あきらめざるを得ないようですね。

お礼

imogasiさん、たびたびすみません。

＞A1:B１２に下記データを置いて

す、すみません、大変失礼いたしましたm(_ _;)m
A1:B12とは、全く関係ないところで実行してました。

＞アイデアだけでも生かしてもらえないと、と思ってしまいますが、
＞私の勝手かも。

とんでもございません、
わたしの分かりにくい質問にご好意で回答いただいたにもかかわらず、
読み返してみたら大変生意気なかき方になっておりました、
もし快感が思いをされておりましたら、何卒ご容赦ください。

本BBSでご回答いただいた内容は、全て保存して、
何度も読み返し、今後も活用させていただいております。
本件に限らず、今後ともよろしくお願いできますと
誠に幸いです。ありがとうございました。

回答No.1

imogasi

質問の個々には難しいものではないと思います。しかし、VBAのコードをここに挙げても、自分のケースに書き換える力が現状あるのか心配です。なければこのコーナーは役立ちません。質問の例は相当簡略化・デフォルメしてあるように思いますので。
（１）（２）（３）（４）は
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
retu = 2
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh1.Range("A65536").End(xlUp).Row
MsgBox d
For i = 1 To d
For j = 1 To retu
sh2.Cells(j, i) = sh1.Cells(i, j)
sh2.Cells(j, i).Font.ColorIndex = 6
Next j
Next i
End Sub
しかし黄色は見にくいですね。
質問B】は
sh2.Cells(j, i).Formula = sh1.Cells(i, j).Formula
が役立つ場合と役立たない（エラーになる）場合があります。
一般には自己参照になる場合や縦横並べ替え対象範囲にあって、本作業で場所が移動する場合の式の番地の変化はに対応するのは、難しい点があるように思えて、即答できない。
【質問C
A1のセルの１０列右であれば、J1（かK1)ですが
上記コードの
A列をJ列に　d = sh1.Range("J65536").End(xlUp).Row
J=1をJ=10 to 10＋retu
iをi+10
にする
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
retu = 2
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh1.Range("J65536").End(xlUp).Row
MsgBox d
For i = 1 To d
For j = 10 To 10 + retu
sh2.Cells(j, i + 10) = sh1.Cells(i, j)
sh2.Cells(j, i + 10).Font.ColorIndex = 3
sh2.Cells(j, i + 10).Formula = sh1.Cells(i, j).Formula
Next j
Next i
End Sub
でどうでしょうか。

お礼

imogasiさんレスありがとうございました。

せっかくご提示いただいたスクリプト、二つとも実行してみたんですが
質問の貼り付けでなく、よくわからない動きをしてしまいます。

実行すると、Msgboxに「1」と表示されて何も起こりません・・
【B】についての考え方はよくわかりました。
ともかく、ありがとうございました。