質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

Q&A

解決済

3回答

1014閲覧

別シートにある表のデータを行列を入れ替えてコピペしたい

shibakoppe

総合スコア35

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

0グッド

0クリップ

投稿2023/04/11 00:01

実現したいこと

  • シート1にある表のデータを行列を入れ替えてシート2にコピペしたい

前提

下記のような表1をマクロを使用して表2の形にして貼付されるようにしたいと考えております。

・表1

番号データ1データ2データ3データ4
1○○○○■■■■△△△△××××
2○○○○■■■■△△△△××××
3○○○○■■■■△△△△××××
4○○○○■■■■△△△△××××
5○○○○■■■■△△△△××××
6○○○○■■■■△△△△××××

・表2

列1列2
○○○○■■■■
△△△△
××××
○○○○■■■■
△△△△
××××
○○○○■■■■
△△△△
××××
○○○○■■■■
△△△△
××××

発生している問題・エラーメッセージ

行列を入れ替えて貼り付けるコードは下記を使用すればよいということはわかったのですが、2列に分けて、なおかつ空白セルを挟む場合のコードが作成できず悩んでおります。

<コード1>

Sub Macro12() Sheets("Sheet1").Range("B1:E4").Copy Sheets("Sheet2").Range("A1").PasteSpecial _ Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True   Application.CutCopyMode = False End Sub

また、以前こちらでお世話になった際に下記のコードをご教示いただき、使用していたのですが、転記元データが4行あるのに対して転記先のデータでは2行しか表示されない等といった現象が起きてしまいました。

<コード2>

Dim wsForm As Worksheet '転記元シート Dim wsPost As Worksheet '転記先シート 'ここは自分で書き換えてください---------------------------------------------- Set wsForm = ThisWorkbook.Sheets("変換前") Set wsPost = ThisWorkbook.Sheets("変換後") Const START_ROW As Long = 2 'データ開始行(タイトル除く) Const DATA_COLUMN As Long = 2 'データは何列目にあるか(今回は例としてA列) '---------------------------------------------------------------------------- 'そのほかの項目 Dim end_row As Long 'データ最終行 end_row = wsForm.Cells(Rows.Count, DATA_COLUMN + 4).End(xlUp).Row '最終行取得(空白を加味して所有者行を基準に設定)※数値不定の為const使用不可 Dim blankCnt As Long '空白行数計算用 Dim rowCnt As Long Dim colCnt As Long With Application .ScreenUpdating = False .EnableEvents = False End With For rowCnt = START_ROW To end_row blankCnt = 0 '空白行数カウント Do While (wsForm.Cells(rowCnt + blankCnt + 1, DATA_COLUMN).Value = "") '次の行が空白じゃなくなるまでループ '最終行に達してたら終了 If rowCnt + blankCnt >= end_row Then Exit Do blankCnt = blankCnt + 1 Loop Call データ転記(wsForm, wsPost, wsForm.Cells(rowCnt, DATA_COLUMN), blankCnt) '邪道ではあるが、空白行数分ループを進める(処理済みなので) rowCnt = rowCnt + blankCnt Next rowCnt With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Private Sub データ転記(form As Worksheet, post As Worksheet, rngData As Range, ByVal cnt As Long) 'データ転記関数 'form :転記元シート 'post :転記先シート 'rngData:転記するデータの先頭セル 'cnt :空白行数(forが0スタートなので処理行数-1であることに注意) Dim rng As Range Dim i As Long Dim col As Long '転記先のA列に転記していく場合 '最後尾セル取得 Set rng = post.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '行→列の順番でループ(項目1のみ処理を変更する)---------------------------------------------------------------- For col = 0 To 5 '3列目なら転記位置が違うので処理を変える(基本部分は同じ) If col = 3 Then Set rng = rng.Offset(-(cnt + 1), 0) '行数を項目1の行数分戻す For i = 0 To cnt If rngData.Offset(i, col).Value = "" Then Exit For '空白セルだったので行探索終了 rng.Offset(0, 1).Value = rngData.Offset(i, col).Value Set rng = rng.Offset(1, 0) '一列下に移動 Next i Else For i = 0 To cnt If rngData.Offset(i, col).Value = "" Then Exit For '空白セルだったので行探索終了 rng.Value = rngData.Offset(i, col).Value Set rng = rng.Offset(1, 0) '一列下に移動 Next i End If Next col '処理終わり---------------------------------- Set rng = Nothing End Sub

試したこと

ループの数値を変更し、転記位置の数値の変更もしたのですが、マクロが動かなくなってしまったり、本来転記されるべきデータが転記されなくなってしまったりと、探れば探るほど原因がわからなくなってしまいました。

私の知識不足で大変申し訳ないのですが、今一度皆様のお力添えをお願いしたく思います。
また、可能でしたら、<コード2>について詳細をご教示いただけますと幸いです。
何卒宜しくお願い致します。

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

pig_vba

2023/04/11 02:01

前回質問(コード添付元)の回答者です。そのコードと今回の質問内容では前提条件が違う(前回のほうが条件が複雑)なのでそのまま流用するのは不可能だと思います。 多分 end_row = wsForm.Cells(Rows.Count, DATA_COLUMN + 4).End(xlUp).Row←二行しか表示されない主原因 →end_row = wsForm.Cells(Rows.Count, 1).End(xlUp).Row とデータ転記内の If col = 3 Then Set rng = rng.Offset(-(cnt + 1), 0) '行数を項目1の行数分戻す For i = 0 To cnt If rngData.Offset(i, col).Value = "" Then Exit For '空白セルだったので行探索終了 rng.Offset(0, 1).Value = rngData.Offset(i, col).Value Set rng = rng.Offset(1, 0) '一列下に移動 Next i Else ↑を全部消せば同じような動きにはなるかもですが、今回の要件に入らない処理だらけなので作り直した方が早いですね
shibakoppe

2023/04/11 02:12

先日は大変お世話になりました。 丁寧にご対応いただいたにもかかわらず、理解が及んでおらず申し訳ございません…。 ご案内いただき、誠にありがとうございました。
guest

回答3

0

ベストアンサー

レイアウトが補足要求の補足通りとすると、
以下のようになります。
シート名は、表1が変換前、表2が変換後とします。

VBA

1Option Explicit 2Public Sub 並べ替え() 3 Dim ws1 As Worksheet 4 Dim ws2 As Worksheet 5 Dim maxrow As Long 6 Dim row1 As Long 7 Dim row2 As Long 8 Set ws1 = Worksheets("変換前") 9 Set ws2 = Worksheets("変換後") 10 maxrow = ws1.Cells(Rows.Count, 2).End(xlUp).Row '最大行取得 11 row2 = 1 12 For row1 = 2 To maxrow 13 ws2.Cells(row2, "A").Value = ws1.Cells(row1, "B").Value 14 ws2.Cells(row2, "B").Value = ws1.Cells(row1, "C").Value 15 row2 = row2 + 1 16 ws2.Cells(row2, "B").Value = ws1.Cells(row1, "D").Value 17 row2 = row2 + 1 18 ws2.Cells(row2, "B").Value = ws1.Cells(row1, "E").Value 19 row2 = row2 + 1 20 Next 21End Sub 22

投稿2023/04/11 02:52

tatsu99

総合スコア5424

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

shibakoppe

2023/04/11 04:22

この度はご教示いただきまして誠にありがとうございました! おかげで無事動かすことができました! お二方にBAを送らせていただきたい気持ちでいっぱいですが、お一人しか選べないため先にご覧いただいたtatsu99様のご回答をBAとさせていただきました。 改めまして、この度は大変お世話になりました!
guest

0

一応、二種類の手法を提示しておきます。

VBA

1 2Sub transposeMacro() 3 4 Dim wsForm As Worksheet '転記元シート 5 Dim rngCpy As Range '転記したいセル 6 7 8 Dim wsPost As Worksheet '転記先シート 9 Dim rngPst As Range '転記先先頭セル 10 11 12 Set wsForm = ThisWorkbook.Sheets("Sheet1") 13 Set wsPost = ThisWorkbook.Sheets("Sheet2") 14 15 Const START_ROW As Long = 2 'データ開始行(タイトル除く) 16 17 Dim end_row As Long 'データ最終行 18 end_row = wsForm.Cells(Rows.Count, 1).End(xlUp).Row '最終行取得(空白を加味して所有者行を基準に設定)※数値不定の為const使用不可 19 20 Dim i As Long 21 22 With Application 23 .ScreenUpdating = False 24 .EnableEvents = False 25 End With 26 27 For i = START_ROW To end_row 28 '転置するデータの先頭列(今回ならデータ2)を登録 29 Set rngCpy = wsForm.Cells(i, 3) 30 31 '転記位置をセット(データ列基準で最下行の1行下を指定) 32 Set rngPst = wsPost.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) 33 34 35 'Sheet2に見出し行がないらしいので初回のみ位置調整(不要なら消してOK) 36 If rngPst.Row = 2 Then Set rngPst = rngPst.Offset(-1, 0) 37 38 39 'データ1をコピー 40 rngPst.Offset(0, -1).Value = rngCpy.Offset(0, -1).Value 41 42 43 'Transpose処理(どっちでも同じ動作。理解しやすい方を使用してください)----------------------------------------------- 44 'Resize(1,3)は「(コピーする範囲を)1行3列に拡張」という意味です。データ2以降が4列以上あるなら3の部分を変更してください。 45 46 47 '①worksheetFunction.Transposeを使う 48 rngPst.Resize(3, 1).Value = WorksheetFunction.Transpose(rngCpy.Resize(1, 3).Value) 49 50 51 '②Pastespecial transposeを使う 52' rngCpy.Resize(1, 3).Copy 53' rngPst.PasteSpecial Paste:=xlPasteValues, Transpose:=True 54 55 '-------------------------------------------------------------------------------------------------------------------- 56 57 Next i 58 59 With Application 60 .ScreenUpdating = True 61 .EnableEvents = True 62 End With 63End Sub 64

イメージ説明

投稿2023/04/11 02:30

編集2023/04/11 02:34
pig_vba

総合スコア807

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

shibakoppe

2023/04/11 04:22

ご教示いただきまして誠にありがとうございました! 説明まで付け加えていただき、本当に嬉しく思います! お教えいただいた方法でも動かすことができました。 お二方にBAを送らせていただきたい気持ちでいっぱいですが、お一人しか選べないとのことなので、pig_vba様にはグッドを送らせていただきます。 改めまして、この度も大変お世話になりました!
guest

0

回答ではありません。補足要求です。
表1のレイアウトは、どちらが正しいのでしょうか。(上ですか、それとも下ですか)(見出し行の確認です)
イメージ説明
イメージ説明

表2のレイアウトは、どちらが正しいのでしょうか。(上ですか、それとも下ですか)(見出し行の確認です)
イメージ説明
イメージ説明

投稿2023/04/11 01:00

tatsu99

総合スコア5424

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

shibakoppe

2023/04/11 02:15

ご覧いただきありがとうございます。 表1には見出し行を設けていますが、表2は見出し行を設けていませんので、 tatsu99様にご提示いただいた画像ですと、表1は上、表2は下になります。 分かりにくい提示をしてしまい申し訳ございません。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問