マンガでよめる痔のこと・薬のこと

【質問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】レベルですと、
もう完全にお手上げ状態です。。。

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

このQ&Aに関連する最新のQ&A

A 回答 (3件)

こんにちは。



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

'<標準モジュール推奨>
'----------------------------------------------
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つの質問の中で、あまり数多く要望を盛り込むのは、私としては、あまり望まれない内容です。なるべく、ご自身の使用の範囲内の疑問や問題点が質問の内容であってほしいですね。
    • good
    • 0
この回答へのお礼

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

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

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

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

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

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

お礼日時:2005/12/18 22:29

#1です。

お礼に関して
>実行すると、Msgboxに「1」と表示されて何も起こりません・・
私は質問の例
A1:B12に下記データを置いて、私のコードを実行し、一応動くことを確認しています。
1C
2D
3E
4F
5G
6H
7I
8J
9K
0L
AM
BN
「Msgboxに「1」と表示され」るのは、A列にデータがないのではないでしょうか。
たとえ何かの間違いが私にあるとしても、それを修正して、アイデアだけでも生かしてもらえないと、と思ってしまいますが、私の勝手かも。
まあ心配は本当になって、残念ながら、本件は私には、あきらめざるを得ないようですね。
    • good
    • 0
この回答へのお礼

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

>A1:B12に下記データを置いて

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

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

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

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

お礼日時:2005/12/18 22:43

質問の個々には難しいものではないと思います。

しかし、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
でどうでしょうか。
    • good
    • 0
この回答へのお礼

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

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

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

お礼日時:2005/12/18 21:48

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング