【質問A】2列×12行に収まった数値があり(これらを選択・コピーして)
任意のセルに貼り付ける際、
(1) 行列を入れ替えて
(2) 一行に並べ
(3) セルの背景を黄色に着色して
(4) 値のみ貼り付け
を一気に済ませたいのです。具体的には、
1C
2D
3E
4F
5G
6H
7I
8J
9K
0L
AM
BN ・・・という元データを
1234567890ABCDEFGHIJKLMN
というイメージ(というか順序)にしたいです。ショートカット
キーに、Ctrl+Shift+Vみたいなのを割当てて多用したいです。
さらに欲張ってすみませんが、
【質問B】上記の条件のうち「値のみ貼り付け」るのでなく、番地を参照する式
(例: =A1、=EF43のような)を埋めるマクロや
【質問C】2列×12行の左上角(上例で言う'1'のセルですね)を選択して
マクロを実行したら、自動で同じ行の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ベストアンサー
- 回答日時:
こんにちは。
ある程度、マクロがおわかりになるようなので、細かな説明はいたしませんし、不具合は、なんとか自力で直していただきたいです。ご要望の全てが入っているはずです。
なお、値貼り付けには、ワークシートの行列を超える貼り付けのエラー処理が付けられていますが、それらエラー処理が十分にチェックされたわけではありません。
'<標準モジュール推奨>
'----------------------------------------------
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 "データは2つ以上ないといけません。", 64: Exit Sub
If Rng.Count = 1 Then MsgBox "セルは2つ以上ないといけません。", 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
- 回答日時:
#1です。
お礼に関して>実行すると、Msgboxに「1」と表示されて何も起こりません・・
私は質問の例
A1:B12に下記データを置いて、私のコードを実行し、一応動くことを確認しています。
1C
2D
3E
4F
5G
6H
7I
8J
9K
0L
AM
BN
「Msgboxに「1」と表示され」るのは、A列にデータがないのではないでしょうか。
たとえ何かの間違いが私にあるとしても、それを修正して、アイデアだけでも生かしてもらえないと、と思ってしまいますが、私の勝手かも。
まあ心配は本当になって、残念ながら、本件は私には、あきらめざるを得ないようですね。
imogasiさん、たびたびすみません。
>A1:B12に下記データを置いて
す、すみません、大変失礼いたしましたm(_ _;)m
A1:B12とは、全く関係ないところで実行してました。
>アイデアだけでも生かしてもらえないと、と思ってしまいますが、
>私の勝手かも。
とんでもございません、
わたしの分かりにくい質問にご好意で回答いただいたにもかかわらず、
読み返してみたら大変生意気なかき方になっておりました、
もし快感が思いをされておりましたら、何卒ご容赦ください。
本BBSでご回答いただいた内容は、全て保存して、
何度も読み返し、今後も活用させていただいております。
本件に限らず、今後ともよろしくお願いできますと
誠に幸いです。ありがとうございました。
No.1
- 回答日時:
質問の個々には難しいものではないと思います。
しかし、VBAのコードをここに挙げても、自分のケースに書き換える力が現状あるのか心配です。なければこのコーナーは役立ちません。質問の例は相当簡略化・デフォルメしてあるように思いますので。(1)(2)(3)(4)は
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のセルの10列右であれば、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】についての考え方はよくわかりました。
ともかく、ありがとうございました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) Excel(VBA) 特定の条件に該当する行の値、書式を同じセルにコピ&ペーストしたいです 1 2022/05/21 18:18
- Excel(エクセル) エクセルのマクロについて教えてください。 2 2023/02/26 13:19
- Excel(エクセル) エクセルのマクロについて教えてください。 3 2023/02/07 14:47
- Visual Basic(VBA) Excelのマクロコードについて教えてください。 1 2022/03/27 13:25
- Visual Basic(VBA) エクセルのマクロについて教えてください。 4 2023/07/04 17:58
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 1 2023/02/27 22:21
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 3 2023/02/28 01:13
- Excel(エクセル) エクセルのマクロでコピー後の貼り付け先を毎回指定したところにしたい 5 2022/08/12 10:47
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2023/01/27 13:15
- Excel(エクセル) マクロVBA別Excelブックにデータ転記 2 2022/07/10 23:35
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Excel VBA インデックスの境...
-
エクセル:VBAで月変わりで、自...
-
VBAで条件が一致する行のデータ...
-
エクセルVBAで実行時エラー...
-
エクセルVBA 別シートの複数の...
-
Excel で行を指定回数だけコピ...
-
VBAの処理が途中で止まる
-
Excel VBA 複数条件にマッチし...
-
EXCEL(マクロ)2つのデータ比...
-
EXCELマクロで全シート対...
-
エクセル2007で、マクロで、結...
-
Excel プロジェクト行程をまと...
-
VBA 最終行取得からの繰り返し貼付
-
エクセルの関数(マクロ?)
-
エクセルVBAで SendKeys "{TAB}"
-
スマホ機種変更で旧機種のGoogl...
-
添付ファイルが開けない
-
携帯修理出して戻ってきたら、L...
-
携帯のmicro SDにデータを保存
-
ドメイン名が、ak.sky.tkk.ne.j...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excel で行を指定回数だけコピ...
-
excelの差込印刷で可視セルだけ...
-
Excel VBA インデックスの境...
-
VBA:同じ文字列データの比...
-
エクセルVBA 別シートの複数の...
-
エクセル:VBAで月変わりで、自...
-
エクセルVBAで SendKeys "{TAB}"
-
VBA別シートの最終行の下行へ貼...
-
歯抜けの時間を埋めて行の挿入
-
エクセルVBAで 2種のリストを...
-
Excel VBAでシート内全体に非表...
-
VBAで複数シート選択
-
EXCELマクロで全シート対...
-
VBAで条件が一致する行のデータ...
-
Excel VBA :2回目以降実行で貼...
-
VBAの指示の内容 昨日こちらで...
-
【WORD差し込み印刷】複数レコ...
-
エクセル シート保護後コメン...
-
Excelでデータの抽出&別シート...
-
エクセルVBAで実行時エラー...
おすすめ情報