マクロについての質問です

質問

表の特定の部分をコピーして、その行列を入れ換えて表示するマクロを作成しました。
Range("G9:J27").Select
Application.CutCopyMode = False
Selection.copy
Sheets("印刷予定").select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
というようなマクロを組んだのですのが、そこから更に追加したい点がありまして。
まずコピーする範囲が毎回変わるので、最終の行を検索して、そこからコピーできるようにしたいのが１点。
あと、はりつけ先の範囲を指定して、表の体裁を整えられればというのがもう1点です。
それぞれについて、何かよい方法がありましたら教えてください。私自身マクロ初心者で、上記も自動でマクロを作成したので、もっとよい方法があるという方もアドバイスを下さい。よろしくお願いします。

回答No.10

hige_082 · ベストアンサー

これでいけますよ

Sub test()
Dim x, y, i
Dim 入力シート As Worksheet
Dim 出力シート As Worksheet

'各シート名を設定してください----------------------
Set 入力シート = Worksheets("sheet1")
Set 出力シート = Worksheets("印刷予定")

Application.ScreenUpdating = False
i = 入力シート.Cells(Rows.Count, 10).End(xlUp).Row
If i < 10 Then Exit Sub
With 出力シート
x = .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
y = .Cells(x - 1, Columns.Count).End(xlToLeft).Column
If .Cells(1, 1).Value = "" Then x = 4: y = 0
For i = 9 To 入力シート.Cells(Rows.Count, 10).End(xlUp).Row
If y < 6 Then
y = y + 1
Else
x = x + 4
y = 1
End If
入力シート.Cells(i, 7).Resize(1, 4).Copy
.Cells(x - 3, y).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.CutCopyMode = False
Next i
End With
Application.ScreenUpdating = True
End Sub

お礼

お礼遅くなって失礼しました。ちょっとコードは変更して使いましたが、なんとか解決しました。
どうもありがとうございました。何度もご解答いただきまして、とても助かりました。今後は今回構築したマクロで仕事が効率よく進められそうです。

回答No.9

mar00

Sub Macro1()

COUNTER1 = 0
COUNTER2 = 1
Sheets("Sheet1").Select
For INP = 1 To Rows.Count
Sheets("Sheet1").Select
If IsEmpty(Cells(INP, 7)) Then
Exit For
Else
COUNTER1 = COUNTER1 + 1
Range(Cells(INP, 7), Cells(INP, 10)).Copy
Sheets("印刷予定").Select
Cells(COUNTER2, COUNTER1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False

If COUNTER1 = 6 Then
COUNTER1 = 0
COUNTER2 = COUNTER2 + 4
End If

End If
Next INP
End Sub

Sheets("Sheet1")のところは、コピー元のデータが入っているシート名に
変更して下さい。(2箇所あります。)

お礼

別の方の回答で無事解決する事ができました。御忙しい中回答をお寄せいただきまして、本当にありがとうございました。今回構築したマクロで仕事をスムーズに進める事ができそうです。

回答No.8

mar00

画像のようになれば良いのでしょうか。

補足

その通りです！！むずかしいでしょうか…

回答No.7

mar00

たびたびすいません#2です。
Sheets("コピーデータのシート名").Range(Cells(i, 7), Cells(i, 10)).Copy
ではなく
Sheets("コピーデータのシート名").Range(Cells(i, 7), Cells(i+4, 10)).Copy
です。

回答No.6

mar00

#2です。
補足を読んだ感じではG9～J13をSheets("印刷予定")のA1にコピー
続いてG14～J118をSheets("印刷予定")のA6にコピーとなっていけば
よいのかと思ったのですが
Sub Macro1()
Sheets("印刷予定").Select
For i = 9 To 10000 Step 5
IF IsEmpty(Sheets("コピーデータのシート名").Cells(i, 7)) Then
Exit For
Else
Sheets("コピーデータのシート名").Range(Cells(i, 7), Cells(i, 10)).Copy
Sheets("印刷予定").Cells(i - 8, 1).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
End If
Next i
End Sub
IFとIsEM\nptyの間にスペースを入れてください。

ではダメですか?

補足

説明不足ですみません。
表の体裁が
１　ア　イ　ウ　エ　オ　カ　キ　ク　ケ　コ　サ
２　シ　ス　セ　ソ　タ　チ　ツ　テ　ト　ナ　ニ
３　ヌ　ネ　ノ　ハ　ヒ　フ　ヘ　ホ　マ　ミ　ム
　　　　　　　　　・
　　　　　　　　　・
というようになっています（ちなみに横軸はABC…のアルファベット順と思っていただいて結構です）。キ～コ、ツ～ナ、ヘ～ミはそれぞれひとつのグループとしてまとめて認識しています。それで、そのグループごとに縦に並び替えたものを、別のシートに左端から順に貼り付けしていきたいのですが、その際にA～Fの範囲内に限って貼り付けをできたらということなのですが。説明下手ですみません。ご理解いただけますか？
それ以外の方法も考えたのですが、単にセルの中の値をコピーして表示するのではなく、着色されているセルはその着色もコピーしたいので、リンク貼り付けでは駄目だということが判明しました。また、着色されたセルを含むデータの抽出は2007以降のバージョンの機能なので、それも使えません。

回答No.5

hige_082

＃４です
＞相変わらず出力先のシート名が無いので
＞sheet2としています
申し訳ありません、書いてありましたm(__)m

表の構成ですが
Sheet1(入力シート)
　ＡＢＣ・・・Ｇ　Ｈ　Ｉ　Ｊ
１
：
９　　　　　　あ　い　う　え
10　　　　　　か　き　く　け
11　　　　　　さ　し　す　せ
：　　　　　　　　：

印刷予定(出力シート)
　　Ａ　Ｂ　Ｃ　Ｄ　Ｅ
１　あ　か　さ　・・・
２　い　き　し　・・・
３　う　く　す　・・・
４　え　け　せ　・・・
５
：　　　　　：

Sheet1のセルG9～J9を先頭に下方向へ入力したものを
印刷予定シートのA1から順に出力していますが違いますか？

入出力のシート設定部分を追加しました

Sub test()
Dim x, y, i
Dim 入力シート As Worksheet
Dim 出力シート As Worksheet

'各シート名を設定してください----------------------
Set 入力シート = Worksheets("sheet1")
Set 出力シート = Worksheets("印刷予定")

Application.ScreenUpdating = False
i = 入力シート.Cells(Rows.Count, 10).End(xlUp).Row
If i < 10 Then Exit Sub
With 出力シート
x = .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
y = .Cells(x - 1, Columns.Count).End(xlToLeft).Column
If .Cells(1, 1).Value = "" Then x = 5: y = 0
For i = 9 To 入力シート.Cells(Rows.Count, 10).End(xlUp).Row
If y < 6 Then
y = y + 1
Else
x = x + 5
y = 1
End If
入力シート.Cells(i, 7).Resize(1, 4).Copy
.Cells(x - 4, y).PasteSpecial Paste:=xlValues, Transpose:=True
Application.CutCopyMode = False
Next i
End With
Application.ScreenUpdating = True
End Sub

参考まで

回答No.4

hige_082

＞なかなか難しく挫折…
やりたいことも良く分かってませんが
一寸複雑なので、初心者には難しいと思うよ

こういう事でよい？

Sub test()
Dim x, y, i
Application.ScreenUpdating = False
i = ActiveSheet.Cells(Rows.Count, 10).End(xlUp).Row
If i < 10 Then Exit Sub
With Worksheets("sheet2")
x = .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
y = .Cells(x - 1, Columns.Count).End(xlToLeft).Column
If .Cells(1, 1).Value = "" Then x = 5: y = 0
For i = 9 To ActiveSheet.Cells(Rows.Count, 10).End(xlUp).Row
If y < 6 Then
y = y + 1
Else
x = x + 5
y = 1
End If
ActiveSheet.Cells(i, 7).Resize(1, 4).Copy
.Cells(x - 4, y).PasteSpecial Paste:=xlValues, Transpose:=True
Application.CutCopyMode = False
Next i
End With
Application.ScreenUpdating = True
End Sub

相変わらず出力先のシート名が無いので
sheet2としています
参考まで

補足

早速コピペして必要箇所のみ修正して使用してみたのですが、うまく作動しません。
いや、作動しているとは思うのですが、その結果がうまく反映されないというか…
エラーが出るわけでもなく、私自身圧倒的に知識が不足しているせいもあって、どこが間違っているのかを見つける事ができませんでした。
せっかく回答いただいたのに、それを生かすことができずすみませんです。

回答No.3

hige_082

＞はりつけ先の範囲を指定して、表の体裁を整えられればというのがもう1点です。
貼り付け先は何処？
表の体制を整えるとは、どのように？

Sub Macro1()
ActiveSheet.Range("G9", Cells(Rows, Count, 10).End(xlUp)).Copy
Worksheets("印刷予定").Range("a1").PasteSpecial Paste:=xlValues, Transpose:=True
Application.CutCopyMode = False
End Sub

コピー先は印刷予定シートのA1にしています
適宜変更してください

参考まで

補足

いただいた回答方法、早速試してみました。
本当にありがとうございます。コピペがうまくできました。
あとは任意の範囲にそれをならべられるようにしたいです。この貼り付けるデータが5行でひとまとまりになっていて、それをたとえばA1～F5まで貼り付けらたらA5～F10へと貼り付け場所を遷移していくようにしたいのですが、できますでしょうか？自分なりに基本となるマクロを自動で作成して、それをうまく統合できないかと思ったのですが、なかなか難しく挫折…
よい方法があれば教えてください。

回答No.2

mar00

>最終の行を検索して、そこからコピーできるようにしたい
私自身もマクロを使い始めたはっかりですが
入力されている行が9行目、そこから最終行ということでしょうか。
GYOU = Cells(9, 7).End(xlDown).Row G列最終行
Range(cells(9,7),cells(GYOU ,10)).copy
cells(9,7)はG9、cells(GYOU ,10は最終行のJ列です。
Sheets("印刷予定").select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
で出来ると思いますよ。

>はりつけ先の範囲を指定して、表の体裁を整えられればというのがもう1点です。
は意味がちょっとわからなかったです。

補足

早速の回答、ありがとうございます。
すみません。説明不足でした。一番最初の列にあたるのがG9～J9で、最終行は毎回変動します。また、体裁を整えるというのは、5行でひとまとまりになっているものを、A1～F5まで貼り付けをしたら、次のA5～H10へと遷移していくようにしたいのです。ひとつずつコピーして貼り付けるのを繰り返し、変数iにその貼り付け回数を代入することでできないかと思ったのですが、うまくいかなくて…
あと、今更なんですけど。もしかしてリンク貼り付けにして作成したほうが便利なのでしょうか？そうすれば入力したのをいちいちコピペしなくとも、任意の場所に表示させる事ができますよね。

回答No.1

FEX2053

Range("G9:J27").Select
Application.CutCopyMode = False

この２行を削除してしまえば、
「現在選択している範囲」を行列を入れ替えて表示する事が可能ですが。

お礼

別の方の回答で無事問題を解決する事ができました。御忙しい中回答をお寄せいただきまして、ありがとうございました。今後は今回構築したマクロで仕事をスムーズに進められそうです。