Excel2000VBAで貼り付け先の取得等・・・

質問

シートに行数13、列数不定の表が上下に多数配置されてます。表は上下それぞれ2行の空白行で隔てられています。
各表は連続した列の部分でひとつですが、中には複数の表を横にならべて、途中1列の空白列で間隔をあけたものもあります。

この、複数の表を横に並べたものを上下に配置しなおすため、以下のように書きました。

質問です。
１．Dim ans As Variantは 'variantで正しいですか？
２．15行（13行＋間隔用2行）挿入にForNext以外にいい方法はないですか？
３．切り取った部分を貼り付ける際、Set XRng = SelectionでなくセレクトせずにXRngを取得できませんか？

他に指摘事項があればお願いします。

Sub TEST()

Dim ans As Variant
Dim Rng As Range, XRng As Range
Dim c As Integer, b As Integer, i As Integer, n As Integer, x As Integer

ans = MsgBox("分離したい表を選択してある？", vbYesNo + vbQuestion)
If ans = vbNo Then Exit Sub

Set Rng = Selection

b = Application.CountBlank(Range(Rng(2, 1), Rng(2, Rng.Columns.Count))) '分離する数を取得

Set XRng = Rng

For i = 1 To b'分離する数だけ繰返し

For n = 1 To 15 '行挿入
XRng.Offset(14, 0).Resize(1, 1).EntireRow.Insert Shift:=xlDown
Next n

c = XRng.Columns.Count '列数取得
x = Range(XRng(1, 1), XRng(1, 1).End(xlToRight)).Columns.Count '最左側部分の列数取得
XRng.Offset(0, x + 1).Resize(13, c - x - 1).Cut '右側カット
Rng.Offset(15 * i, 0).Resize(1, 1).Select '貼付け開始位置セレクト
ActiveSheet.Paste '貼付け
Set XRng = Selection 'XRng再取得

Next i

End Sub

回答No.3

KenKen_SP · ベストアンサー

こんにちは、KenKen_SP です。

▼ Q1 Dim ans As Variantは 'variantで正しいですか？

Variant でもいいですけど、ヘルプによると Integer です。
参考) VBA ヘルプ Msgbox 関数

Variant や Long、Integer などの変数でエラーにはなりませんが、あえて型を
問題にする、つまり変数の「暗黙の型変換」を許さない厳密なコードを書きたい
ということならば、変数を Integer にするだけでは不足です。

vbYesNo などの Msgbox に関する定数は Enum vbMsgBoxStyle で定義されてます。
Enum で列挙された定数の型は Long 型ですから、vbYesNo などの定数を使うなら

　　Dim ans As Integer
　　ans = MsgBox("分離したい表を選択してある？", vbYesNo + vbQuestion)
　　If CLng(ans) = vbNo Then Exit Sub

となります...ここまでする必要性は VB(A) では全く無いですけどね。
参考) TypeName(vbYesNo) --> Long

▼ Q2～3 について

コードが動くならあとは好みの問題でしょう。一応、サンプルを書いてみます。
Undo がきかない VBA でオリジナル表を直接操作するのは危険なので、新規シート
にコピーする仕様にしてます。

For Each がどのように Range を拾っていくのか確認してみて下さい。
詳しくはソースで。

Sub SampleProc()

　　Dim rTables As Range
　　Dim rTable　As Range
　　Dim Sh　　　As Worksheet
　　Dim lRowPos As Long

　　Const MARGIN_ROW_CNT = 2

　　On Error Resume Next
　　Set rTables = ActiveSheet.UsedRange _
　　　　　　　　.SpecialCells(xlCellTypeConstants, 23)
　　If Err Then Exit Sub
　　On Error GoTo 0

　　Application.ScreenUpdating = False

　　Set Sh = ThisWorkbook.Worksheets.Add
　　lRowPos = 1
　　For Each rTable In rTables.Areas
　　　　With rTable.CurrentRegion
　　　　　　.Copy Destination:=Sh.Cells(lRowPos, 1)
　　　　　　lRowPos = lRowPos + .Rows.Count + MARGIN_ROW_CNT
　　　　End With
　　Next
　　Set Sh = Nothing
　　Set rTables = Nothing

End Sub

▼ Q4 他に指摘事項があればお願いします。

んー...上述の事項に関連付けて言えば、Row も Column も Long 型の値を返す
プロパティーですから、それを受ける変数はどちらも Long 型にすべきかな...

お礼

ありがとうございます。
KenKen_SPさまは相変わらずすごいですねぇ。

教えてください。
ヘルプの使い方が下手なのか、.SpecialCells(xlCellTypeConstants, 23)の引数「23」がわかりません。数値と文字列なのでしょうか？

> 新規シートにコピーする仕様にしてます。
そうですね、そのほうがいいですね。

> With rTable.CurrentRegion
ここで例にあげたレイアウトは説明を簡単にするために単純化したものなのです。他のデータと隣接しているものも多数あります。
したがって、CurrentRegionでは正しく範囲を取得できないのです。

回答No.6

taocat

お師匠さん、おひさです。
またまた面白そうなことやってますねぇ。。(^^;;;

お師匠さんのを修正、Selectなし
テーブルは、１５行が、２段、３段とあった場合（１段でもいいが）
----------------------------------------------------------
Sub TEST()
Dim Ans As Variant
Dim Rng As Range, XRng As Range
Dim c As Integer, b As Integer, i As Integer, N As Integer, x As Integer

Ans = MsgBox("分離したい表を選択してある？", vbYesNo + vbQuestion)
If Ans = vbNo Then Exit Sub

Set Rng = Selection
Set XRng = Rng

b = Application.CountBlank(XRng.Rows(2))

For i = 1 To b

　XRng.Offset(15, 0).Resize(15).EntireRow.Insert Shift:=xlDown

　c = XRng.Columns.Count
　x = Range(XRng(1, 1), XRng(1, 1).End(xlToRight)).Columns.Count

　Set XRng = XRng.Offset(0, x + 1).Resize(13, c - x - 1)

　XRng.Cut Destination:=Rng.Offset(15 * i, 0).Resize(1, 1)

Next i

End Sub
--------------------------------------------------------------

--------------------------------------------------------------
KenKenSPさんのをパクると。。(^^;;;
但し、この方法では範囲の有効テーブルの中に空白セルがあったり
計算式のセルがあったりすると上手くいきません。
例えば、A1-C13、D列空き、E1-F13、G列空き、H1-J13・・・・
とあり選択範囲を、E1-J13としたとき、E1-F13,H1-J13の中に
ひとつでも空白セルがあったり、計算式があったりした場合です。

---------------------------------------------------------
Sub Test222()

　Dim SelectRange As Range
　Dim MovePoint As Range
　Dim N As Integer
　Dim Ans As Variant

　Ans = MsgBox("分離したい表を選択してある？", vbYesNo + vbQuestion)
　If Ans = vbNo Then Exit Sub

　Set SelectRange = Selection.SpecialCells(xlCellTypeConstants, 23)

　For N = 2 To SelectRange.Areas.Count
　　Set MovePoint = Cells((N - 1) * 15 + 1, SelectRange.Areas(1).Column)
　　MovePoint.Resize(15).EntireRow.Insert xlShiftDown
　　SelectRange.Areas(N).Cut Destination:=MovePoint.Offset(-15)
　Next N

End Sub
---------------------------------------------------------

以上です。

お礼

あ、道士さま　おひさしゅうございます。

> Set XRng = XRng.Offset(0, x + 1).Resize(13, c - x - 1)
> XRng.Cut Destination:=Rng.Offset(15 * i, 0).Resize(1, 1)

なんと、CutにSetしておけば、貼り付け先がXrngになるんですね！！
未熟者ゆえまったく思いもよりませんでした・・・。

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

補足

お礼（↓）を訂正します

×CutにSetしておけば・・・
○Cutする前にSet XRngしておけば・・・

回答No.5

KenKen_SP

> Selection.Copy Range("J92")
> MsgBox Selection.Address
> では、貼り付け元しか取得できないのと同じだと思います

んー。あまり意義が理解できていないのですけど...この点が今回のご質問の
ポイントになるのでしょうか？

> XRng.Offset(0, x + 1).Resize(13, c - x - 1).Cut '右側カット

の Resize(13, c - x - 1) が貼り付け先の Rows.Count, Columns.Count に
相当する、つまり、 コピー元 Range の Row, Column の数は、貼り付け先
の Row, Column の数と一緒ということです。ということは、

基点のセルが決まれば

　　Selection.Copy Range("J92")
　　MsgBox Range("J92").Resize(13, c - x - 1).Address

のように、Resize を使って貼り付け先の Range が取れませんか？

お礼

> 基点のセルが決まれば
>　　Selection.Copy Range("J92")
>　　MsgBox Range("J92").Resize(13, c - x - 1).Address
> のように、Resize を使って貼り付け先の Range が取れませんか？

おっしゃる通です。
XRng.Offset(0, x + 1).Resize(13, c - x - 1).Cut Rng.Offset(15 * i, 0).Resize(1, 1)
Set XRng = Rng.Offset(15 * i, 0).Resize(1, 1).Resize(13, c - x - 1)
MsgBox XRng.Address
で、取得できました。

でも
Set XRng = XRng.Offset(0, x + 1).Resize(13, c - x - 1)
XRng.Cut Destination:=Rng.Offset(15 * i, 0).Resize(1, 1)
MsgBox XRng.Address
のほうがもっと簡単でしたね。
ありがとうございました。

回答No.4

KenKen_SP

> 、.SpecialCells(xlCellTypeConstants, 23)の引数「23」がわかりません。
> 数値と文字列なのでしょうか？

ヘルプで SpecialCells を引いてみます。

　　expression.SpecialCells(Type, Value)

23 の部分は第二引数なので、引数 Value の方ですね。さらに引数 Value
の解説を見ると...

　　(略)～XlSpecialCellsValues クラスの定数を使用します。

とリンクがあって、そこをクリックすると定数の内容が表示されます。

　　xlErrors
　　xlLogical
　　xlNumbers
　　xlTextValues

ここで、VBE 画面で F2 キーを押すと「オブジェクトブラウザ」が表示され
ますので、例えば、xlErrors を検索すると、、

　　Const xlErrors = 16 (&H10)

などと定数の値がわかります。VBA ユーザーが意識することはありませんが、
VBA で予め

　　Enum XlSpecialCellsValue
　　　　xlErrors = 16
　　　　xlLogical = 4
　　　　xlNumbers = 1
　　　　xlTextValues = 2
　　End Enum

といった定義があるからこそ、プログラム内で xlErrors といった文字列で定数
として表現できる仕組みになってます。

ここで、23 とは、　xlErrors + xlLogical + xlNumbers + xlTextValues
つまり、　16 + 4 + 1 + 2 ＝ 23　の意味ですね。

プログラムを書くときは今回のように 23 などという数字がいきなりでて
くると、その意味がわかりません。（これをマジックナンバーと言います）

そこでプログラムに慣れた人なら通常はこんな書き方をします。

Const ALLVALUETYPE = xlErrors Or xlLogical Or xlNumbers Or xlTextValues
（略～）
Selection.SpecialCells(xlCellTypeConstants, ALLVALUETYPE)

　--> 定数の連結には Or 演算子が使われます

あるいは、コメントに意味の説明を入れておきます。

今回はちょっと手抜きしてしまったのでした...

> 他のデータと隣接しているものも多数あります。
> したがって、CurrentRegionでは正しく範囲を取得できないのです。

そうですか...ご提示の条件で作成したものなので、空列が無いと #3 は上手く
できませんのでボツですね。まあ、こんな方法もある...との参考意見という
ことで(´・ω・`)

表の切り分け条件がわからないので、現状ではこれ以上の回答はできませんが、
先に行挿入しているなら、クリップボードを介さないで、

Cut Destination:=基準セル.Offset(基準セルからのオフセット値)

といった書き方でやってみて下さい。（この辺は参考になるかも）

お礼

ありがとうございます。
表の回りの隣接部分は、表の名前や、項目名、脚注などの文字列なので、一旦消去し、KenKen_SPさまの素晴らしいコードを使わせていただくことにしました。ありがとうございます。

ただ、今後の参考のため、以下をご教示くださると幸いです。
何度もすみません。

> Cut Destination:=基準セル.Offset(基準セルからのオフセット値)
> といった書き方でやってみて下さい。（この辺は参考になるかも）

すでにやってみました。No2さんへのお礼にも書きましたが、

XRng.Offset(0, x + 1).Resize(13, c - x - 1).Cut '右側カット
Rng.Offset(15 * i, 0).Resize(1, 1).Select '貼付け開始位置セレクト
ActiveSheet.Paste '貼付け

この部分を、セレクトせず

XRng.Offset(0, x + 1).Resize(13, c - x - 1).Cut Rng.Offset(15 * i, 0).Resize(1, 1)

にすると、Selectしてないので
Set XRng = Selection 'XRng再取得
では貼り付け先の範囲を取得できないのです。

Selection.Copy
Range("J92").Select
ActiveSheet.Paste
MsgBox Selection.Address
なら貼り付け先範囲が取得できますが、

Selection.Copy Range("J92")
MsgBox Selection.Address
では、貼り付け元しか取得できないのと同じだと思います。

回答No.2

myCat

こんにちは。

●テーブル切れ目カウント

　b = Application.CountBlank(Rng.Rows(2))

●１５行挿入

　XRng.Offset(15, 0).Resize(15).EntireRow.Insert xlShiftDown

●Set XRng = SelectionでなくセレクトせずにXRngを取得できませんか？

ちょっと意味不明？？？

お礼

> ●１５行挿入
> XRng.Offset(15, 0).Resize(15).EntireRow.Insert xlShiftDown

一発で1挿入されました！
ありがとうございます。　(*´∇｀*)

> ●Set XRng = SelectionでなくセレクトせずにXRngを取得できませんか？
> ちょっと意味不明？？？

貼り付け開始位置（セル1個所）を取得し、Cutされた範囲を貼り付けた範囲（Range）を取得したいということです。

XRng.Offset(0, x + 1).Resize(13, c - x - 1).Cut '右側カット
Rng.Offset(15 * i, 0).Resize(1, 1).Select '貼付け開始位置セレクト
ActiveSheet.Paste '貼付け

この部分を
XRng.Offset(0, x + 1).Resize(13, c - x - 1).Cut Rng.Offset(15 * i, 0).Resize(1, 1)
にすると、Selectしてないので

Set XRng = Selection 'XRng再取得

では貼り付け先の範囲を取得できません。

補足

> b = Application.CountBlank(Rng.Rows(2))

なんと、これで取得できちゃうんですね！
ありがとうございます。

回答No.1

ja7awu

>１．Dim ans As Variantは 'variantで正しいですか？

そういうときは、ヘルプを活用する習慣を付けましょう。
「整数型 (Integer) の値を返します。」とありますから、Integer でいいと思います。

> ２．15行（13行＋間隔用2行）挿入にForNext以外にいい方法はないですか？

まぁ、ずっと下の使っていない15行をコピーして挿入するとか・・・

> ３．切り取った部分を貼り付ける際、Set XRng = SelectionでなくセレクトせずにXRngを取得できませんか？

意味がいまいち特定出来ませんが、移動する範囲を自動的に認識できる条件が、シート構成に
あれば、セレクトしなくても、出来ると思いますが・・・

あと、この状態では、変数にセットしなくても、Selection のままでいいとも思います。

それと、Set Rng = Selection　の 2行下に Set XRng = Rng があるのが、何故って感じです。

> 他に指摘事項があればお願いします。

このコードは、正常に動作しているのですね。
表のレイアウトが分らないためと思いますが、再現に努めましたが、Cut の行で Err-1004になります。

> b = Application.CountBlank(Range(Rng(2, 1), Rng(2, Rng.Columns.Count))) '分離する数を取得

もしかして、こういうことでしょうか。

　b = Application.CountBlank(Rng.Resize(1).Offset(1))

こんな感じですが、如何でしょうか。

お礼

> 「整数型 (Integer) の値を返します。」

MsgBox ans　でみたら確かに整数が返ってきました。ありがとうございます。

> Set Rng = Selection　の 2行下に Set XRng = Rng があるのが、何故

貼り付け開始位置を取得するのに当初のRngの場所を固定しておきたかったから、新たにXRngを設定しました。

>　表のレイアウトが分らないためと思いますが、再現に努めましたが、Cut の行で Err-1004になります。

再度試しましたが、こちらではエラーになりません。

例えば、B2:D14,F2:I14,K2:O14というように横に３つ、表が一列あけて並んでいるとします。
2行あけて、B17以降にも表があります。
B2:O14を連続して選択し、マクロを走らせると、

B2:D14
B17:E29
B32:F44

のように縦に３つに変わります。
最初にB17以降にあった表は、B47以降に下に移動しています。

> もしかして、こういうことでしょうか。
>　b = Application.CountBlank(Rng.Resize(1).Offset(1))

そ、その通りでございます。(^^;;
ありがとうございました。