質問: 6 end with end sub しかし、(2)はたぶん私が全く理解できない配列を使わなければ 実現しないと推察します。さらに、【b】【c】レベルですと、 もう完全にお手上げ状態です。。。 どうぞ、よろしくお願い致します。
回答: こんにちは。 ある程度、マクロがおわかりになるようなので、細かな説明はいたしませんし、不具合は、なんとか自力で直していただきたいです。ご要望の全てが入っているはずです。 なお、値貼り付けには、ワークシートの行列を超える貼り付けのエラー処理が付けられていますが、それらエラー処理が十分にチェックされたわけではありません。 '<標準モジュール推奨> '---------------------------------------------- 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つの質問の中で、あまり数多く要望を盛り込むのは、私としては、あまり望まれない内容です。なるべく、ご自身の使用の範囲内の疑問や問題点が質問の内容であってほしいですね。