• ベストアンサー

ExcelVBA:行列入れ替えと文字の複数コピー

VBA初心者です。お教え下さい。 下記の元データを 【元データ】 NO A-NO S1 S2 S3 S4 S5 AAA1 A1　 1 2 3 4 5 AAA1 A2 11 12 13 14 15 BBB2 A3 21 22 23 24 25 BBB2 A4 31 32 33 34 35 それを、下記のようにしたいんです。 NO A-NO AAA1 A1 S1 1 AAA1 A1 S2 2 AAA1 A1 S3 3 AAA1 A1 S4 4 AAA1 A1 S5 5 AAA1 A2 S1 11 AAA1 A2 S2 12 AAA1 A2 S3 13 AAA1 A2 S4 14 AAA1 A2 S5 15 BBB2 A3 S1 21 BBB2 A3 S2 22 BBB2 A3 S3 23 BBB2 A3 S4 24 BBB2 A3 S5 25 BBB2 A4 S1 31 BBB2 A4 S2 32 BBB2 A4 S3 33 BBB2 A4 S4 34 BBB2 A4 S5 35 検索などして、行列の入れ替えを試していたのですが、うまくいきません。 お知恵を拝借させて下さい。 Sub macro() Dim LastRow, Trow, i As Long LastRow = Range("A65536").End(xlUp).Row + 4 For i = 1 To Int(LastRow / 5 Trow = i * 5 - 4 Cells(Trow, 12) = Cells(Trow, 1) Cells(Trow + 1, 12) = Cells(Trow, 2) Cells(Trow + 2, 12) = Cells(Trow, 3) Cells(Trow + 3, 12) = Cells(Trow, 4) Cells(Trow + 4, 12) = Cells(Trow, 5) Next Range(Cells(1, 1), Cells(LastRow, 5)).Clear End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • hotosys
  • ベストアンサー率67% (97/143)
回答No.1

行列の入れ替えは「形式を指定して貼り付け」の「行列を入れ替える」を使うと短くて楽かも。 色々やり方はあるだろうけど、Sheet1からSheet2に作る場合。 Sub sample() Dim srcSheet As Worksheet Dim dstSheet As Worksheet Dim srcRow As Long Dim dstRow As Long Set srcSheet = Sheets("Sheet1") Set dstSheet = Sheets("Sheet2") 'クリア dstSheet.Cells.Clear '見出しコピー srcSheet.Range("A1:B1").Copy Destination:=dstSheet.Range("A1:B1") dstRow = 2 For srcRow = 2 To srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row 'NOとA-NOを行方向5行にコピー srcSheet.Cells(srcRow, "A").Resize(1, 2).Copy Destination:=dstSheet.Cells(dstRow, "A").Resize(5, 2) '[S1 S2 S3 S4 S5]見出しコピー srcSheet.Range("C1:G1").Copy '行列を入れ替えて貼り付け dstSheet.Cells(dstRow, "C").PasteSpecial Transpose:=True '[S1 S2 S3 S4 S5]データコピー srcSheet.Cells(srcRow, "C").Resize(1, 5).Copy '行列を入れ替えて貼り付け dstSheet.Cells(dstRow, "D").PasteSpecial Transpose:=True 'コピー先+5 dstRow = dstRow + 5 Next Application.CutCopyMode = False End Sub

goo397620
質問者

お礼

早速回答ありがとうございます！ うまくいきました！感動です！ 本当、ありがとうございました！

その他の回答 (1)

  • hallo-2007
  • ベストアンサー率41% (888/2115)
回答No.2

【元データ】 NO A-NO S1 S2 S3 S4 S5 AAA1 A1　 1 2 3 4 5 AAA1 A2 11 12 13 14 15 BBB2 A3 21 22 23 24 25 BBB2 A4 31 32 33 34 35 は　S1～S5まで固定ですか 別シート A列に　=INDEX(元データ!A:A,INT(ROW(A5)/5)+1)　B列にコピイ　下までコピイ C列に　=INDEX(元データ!C:G,INT(ROW(C5)/5)+1,MOD(ROW(C5),5)+1) 下までコピイでは　ダメでしょうか。

goo397620
質問者

お礼

早速の回答ありがとうございます！ Ｓ１～Ｓ５は固定なんです。 そして、回答頂いた内容で、思い通りの結果が得られました！ 本当にありがとうございました！

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • 横にコピーするには・・。

    教えてください・・。 01.xls・02.xls・03.xlsとあり、その中のシート（01・02・03）をコピーして、全部というシートにまとめたいと思っています。 列にデータを追加したいのですが、行にデータが追加されてしまいます・・。 どうしたらいいのか教えてください。 01のシートがＡからＤまで 02のシートがＥからＧまで 03のシートがＨからＬまで とコピーをしたいと思っています・・。 --------- PathName = ThisWorkbook.Path & "\" ArrBook = Array("01.xls", "02.xls", "03.xls") For i = LBound(ArrBook) To UBound(ArrBook) Workbooks.Open PathName & ArrBook(i) Next Set WS(1) = Workbooks("01.xls").Worksheets("01") Set WS(2) = Workbooks("02.xls").Worksheets("02") Set WS(3) = Workbooks("03.xls").Worksheets("03") Set WS(4) = ThisWorkbook.Worksheets("全部") With WS(4) .Cells.ClearContents .Cells(1, 1) = "Ａ" .Cells(1, 2) = "B" .Cells(1, 3) = "C" .Cells(1, 4) = "D" .Cells(1, 5) = "E" .Cells(1, 6) = "F" .Cells(1, 7) = "G" .Cells(1, 8) = "H" .Cells(1, 9) = "I" .Cells(1, 10) = "J" .Cells(1, 11) = "K" .Cells(1, 12) = "L" .Cells(1, 13) = "M" .Cells(1, 14) = "N" .Cells(1, 15) = "O" .Cells(1, 16) = "P" .Cells(1, 17) = "Q" LastRow(1) = WS(1).Range("A65536").End(xlUp).Row LastRow(2) = WS(2).Range("A65536").End(xlUp).Row LastRow(3) = WS(3).Range("A65536").End(xlUp).Row For i = 1 To 3 LastRow(4) = .Range("A65536").End(xlUp).Row + 1 WS(i).Rows("2:" & LastRow(i)).Copy .Cells(LastRow(4), 1) LastRow(4) = .Range("A65536").End(xlUp).Row End With For i = LBound(ArrBook) To UBound(ArrBook) Workbooks(ArrBook(i)).Close SaveChanges:=False Next End Sub

  • 重複時の網掛けについて

    以前、重複行を網掛けにする処理で質問を載せましたが、 もう少し深くやりたくて試しているのですが、 無限ループが発生して困っております。 A B 1 aaa 1 aaa 1 aaa 2 aaa 2 aaa 2 aaa 3 bbb 3 bbb 4 aaa 4 aaa 上記データがあって結果を A B C 1 aaa 重複 1 aaa 重複 1 aaa 重複 2 aaa 重複 2 aaa 重複 2 aaa 重複 3 bbb パス 3 bbb パス 4 aaa パス 4 aaa パス B列の値が同じの場合は、A列の番号が大きいもののみパスと するように処理を作成しようと思っております。 下記でまずはどのように値が返ってくるか試したのですが、 無限ループになってしまいました。 Dim i As Integer Dim n As Integer LastRow = Range("A65356").End(xlUp).Row For i = 1 To LastRow A_retsu = Cells(i, 1).Value B_retsu = Cells(i, 2).Value For n = 1 To LastRow If A_retsu = Cells(n, 1).Value And B_retsu = Cells(n, 2) Then MsgBox "パス" Else MsgBox "重複" End If Next Next End Sub 最終結果は、 3 bbb パス 3 bbb パス 4 aaa パス 4 aaa パス 上記だけを残して他は削除させる処理を作りたいです。 すいませんがお願いします

  • 複数の列を繋げてＡ列に入れたい　ＶＢＡ

    aaa aaa　　bbb aaa　　bbb　　ccc aaa (A列にaaa、B列にbbb、C列にcccが入ってます) と言うデータがあるのですが 全てＡ列に入れて aaa aaabbb aaabbbccc aaa としたいです。 ・最終列は必ずしもＣではないのです。（Dの場合もEの場合もある） ・最終行も変化します。 Sub 分かれてる列を繋げる() Dim Col As Long Dim Row As Long For Row = 1 To Range("a65536").End(xlUp).Row 　　For Col = 1 To Cells(Row, 256).End(xlToLeft).Column 　　　Cells(Row, 1) = Cells(Row, 1) & Cells(Row, 2) & Cells(Row, 3) 　　 Next Col Next Row End Sub をやってみましたが、 aaa aaabbbbbb aaabbbcccbbbcccbbbccc aaa となってしまい、 欲しい結果とは違くなってしまいます。

  • 二つのマクロで一気に処理したい

    以下のようなことができるのかお伺い致します。よろしくお願い致します。 　やりたいこと 　　※　前提として、sheet1にすでにA列に通し番号で奇数の数字が入っている。 　　　1.sheet1からsheet2へコピペーストする。しかし、A列からO列のすべてにデータがあった場合のみコピー貼り付けさせたい。 　　　　(前提で示したように、A列に通し番号で奇数の数字が入っていて、A列のみ数字があり、以外が空欄の行があるため) 　　　2.下記のコピー貼り付けのコードと重複削除のコードを合体させて、一つの処理で動かしたい。 Sub コピー貼り付けつけ()　　'コピー貼り付けつけのコード Dim lastRow As Long 'Sheet1のA3から最終行までをコピー With Sheets("sheet1") .Range("A3:O" & .Cells(Rows.Count, "A").End(xlUp).Row).Copy End With 'Sheet2のA列の最終行の次の行に貼付け Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Application.CutCopyMode = False End Sub Sub 重複データを一括削除する() ' Macro1 Macro Dim i As Long, lastRow As Long, myRng As Range LastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = 1 To lastRow - 1 If WorksheetFunction.CountIf(Range(Cells(i + 1, "O"), Cells(lastRow, "O")), Cells(i, "O")) > 0 Then If myRng Is Nothing Then Set myRng = Cells(i, "O") Else Set myRng = Union(myRng, Cells(i, "O")) End If End If Next i If Not myRng Is Nothing Then myRng.EntireRow.Delete End If End Sub

  • Excelでマクロを使いセルの内容をコピー貼り付け

    A1セルに111と入力してあるとします。 この時B1にaaa111aaaと入力するマクロを作りたいです。 A1に222があるとB1はaaa222aaaと入力したいです。 これをマクロで作ったのですが、次のようになり、A1の内容にかかわらず常にaaa111aaaとなってしまいます。 Sub Macro1() Range("A1").Select ActiveCell.FormulaR1C1 = "111" Range("B1").Select ActiveCell.FormulaR1C1 = "aaa111aaa" Range("B2").Select Application.Goto Reference:="Macro2" End Sub これのいらない行を削除し、コピーはA1の内容となるように修正して次のようにしました。 Sub Macro1() ActiveCell.FormulaR1C1 = Range("A1") Range("B1").Select ActiveCell.FormulaR1C1 = "aaa111aaa" Application.Goto Reference:="Macro2" End Sub まだペーストするときにA1の内容とならず直接入力となっています。 これをどう変更すればいいでしょうか？

  • Excel VBAで文字列の部分一致の文字列を表示

    以前、こちらで頭５文字までの一致で文字列を表示するVBAを教えて頂きました。今回はFINDなどの部分一致での文字列を表示することをしたいのですが、ご教示いただけますと幸いです。 下記はSheet1のA3に文字を5文字以内いれるとSheet２のC列からピックアップしてSheet１のA列に文字列を表示する及びSheet２のB列のデータをSheet１のC列に表示させるVBAです。 Sub Test2() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim SData As String, i As Long, VRet As Variant Dim c As Range, LastRow As Long Set Ws1 = Sheets("Sheet1") Set Ws2 = Sheets("Sheet2") SData = CStr(Ws1.Range("A3").Value) If SData = "" Then Exit Sub i = 5 LastRow = Ws1.Cells(Rows.Count, "A").End(xlUp).Row If LastRow < i Then LastRow = i End If Ws1.Range(Ws1.Cells(i, "A"), Ws1.Cells(LastRow, "C")).ClearContents With Ws2 For Each c In .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp)) VRet = InStr(1, CStr(c.Value), SData, vbTextCompare) If VRet = 1 And Len(c.Value) >= 10 Then Ws1.Cells(i, "A").Resize(1, 2).Value = c.Resize(1, 2).Value 'とりあえずSheet2のB列のデータ(C列のデータに同期したデータ)をSheet1のC列に Ws1.Cells(i, "C").Value = .Cells(c.Row, "B").Value i = i + 1 End If Next End With End Sub 宜しくお願い致します。

  • rangeからcellsに帰る場合の書式

    Sub Macro1() Range("A1").Activate Selection.AutoFill Destination:=Range("A1:A10"), Type:=xlFillDefault End Sub をRangeではなくCellsに変えたいのですが、 Sub Macro2() Range("A1").Activate Selection.AutoFill Destination:=Range(Cells(1, 1) & ";" & Cells(10, 1)), Type:=xlFillDefault End Sub だと、 実行時エラー１００４になってしまいます。 Sub Macro3() Range("A1").Activate Selection.AutoFill Destination:=Range(Cells(1, 1), Cells(10, 1)), Type:=xlFillDefault End Sub だとうまくいくのですが、 なぜRengeの時は、「；」なのに、cellsの時は、「、」でいいのでしょうか？

  • ExcelVBA 変数を使ってセルの番地を表す

    Exce2000のlVBAで Sub Macro11() Dim LastColumn As Integer Dim LastRow As Integer LastColumn=5 LastRow=1 Range(("LastColumn"), ("LastRow")).Select End Sub と打ち込むとエラーが出ます． 変数を使ってセルの番地を指定して セルを選択できないでしょうか？

  • VBA 最終行を選んだシートにコピーする。

    VBAど初心者です。どうしても最終行のデータを選んだシートにコピーできません。 LastRow.Selectのところで、止まってしまいます。どのように行を設定していいのかさっぱりわかりません。どなたか、ご指導のほどよろしくお願いします。 Sub copy_last_line() Dim LastRow As Long Sheets("Sheet1").Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row LastRow.Select Selection.Copy Sheets("Sheet2").Select Range("A1").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("A1").Select End Sub

  • 『エクセル』　vbaでオートフィルができない

    Sub Macro1() Range("a1:a10").Select Selection.AutoFill Destination:=Range("A1:A10"), Type:=xlFillSeries End Sub がエラーになります。 内容は「RangeクラスのAotofillメソッドが失敗しました」 となります。 Sub Macro2() Dim i As Long For i = 1 To 10 Cells(i, 1) = i Next End Sub や Sub Macro3() Dim i As Long i = 1 While i <= 10 Cells(i, 1) = i i = i + 1 Wend End Sub と同じような動きをAutoFillを使ってＶＢＡで行いたいのですが むりでしょうか？ というのも、 A1に長い関数式を入れて A10000までオートフィルしたいのですが 手作業だと時間がかかるためマクロで行いたいです。 アドバイス宜しくお願い致します。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する