シート1
名前 役職
武田信玄 社長
織田信長 副社長
上杉謙信 専務
前田利家 営業
etc..
これを
シート2
名前 役職 名前 役職 名前 役職
武田信玄 社長 織田信長 副社長 上杉謙信 専務
前田利家 営業 etc..
という風に、シート1をシート2に代入するときに、横に記入されるようにしたいのですが、Copyメソッドを利用するとそのままコピーされてしまい、
シート2のようにならないづに困っています。*名前と役職については、すでに書かれています
どなたか詳しい方がいましたら、ご教授ください。
気になる質問をクリップする
クリップした質問は、後からいつでもMYページで確認できます。
またクリップした質問に回答があった際、通知やメールを受け取ることができます。
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2018/04/03 09:20
2018/04/04 00:24
回答3件
0
コピー元をループしながら、コピー先に代入
サピー先の座標は、列数から計算できます。
コードをシンプルにするために、Offset を使いました。
vba
1Public Sub 可変列() 2 Dim Rng1 As Range, Rng2 As Range 3 Dim MaxRow As Long, MaxCol As Long 4 Dim i As Long 5 6 If Worksheets("Sheet1").Range("A1").Value = "" Then 7 MsgBox "データがありません。" 8 Exit Sub 9 End If 10 11 Set Rng1 = Worksheets("Sheet1").Range("A1", "B1") 'コピー元の最初のセル範囲 12 Set Rng2 = Worksheets("Sheet2").Range("A1", "B1") 'コピー先の最初のセル範囲 13 14 MaxRow = Rng1.End(xlDown).Row 'コピー元の行数 15 MaxCol = Rng2.End(xlToRight).Column 'コピー先の項目の列数 16 17 For i = 1 To MaxRow 18 Rng2.Offset(1 + ((i - 1) \ (MaxCol \ 2)), ((i - 1) * 2) Mod MaxCol).Value _ 19 = Rng1.Offset(i).Value 20 Next 21End Sub
配列を使用して高速化したバージョン
vba
1Public Sub 可変列へ転記_配列() 2 Dim aryFrom(), aryTo() 3 Dim MaxRow As Long, MaxCol As Long 4 Dim i As Long, r As Long, c As Long 5 6 If Worksheets("Sheet1").Range("A1").Value = "" Then 7 MsgBox "データがありません。" 8 Exit Sub 9 End If 10 11 MaxRow = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count 12 MaxCol = Worksheets("Sheet2").Range("A1").CurrentRegion.Columns.Count 13 14 aryFrom = Worksheets("Sheet1").Range("A2", "B" & MaxRow).Value 'コピー元のデータを配列に格納 15 ReDim aryTo(1 To MaxRow \ (MaxCol \ 2) + 1, 1 To MaxCol) '出力先配列のサイズを確保 16 17 18 For i = 1 To MaxRow - 1 19 r = 1 + ((i - 1) \ (MaxCol \ 2)) 20 c = ((i - 1) * 2) Mod MaxCol + 1 21 aryTo(r, c) = aryFrom(i, 1) 22 aryTo(r, c + 1) = aryFrom(i, 2) 23 Next 24 25 Worksheets("Sheet2").Range("A2").Resize(UBound(aryTo), MaxCol).Value = aryTo 26End Sub 27
投稿2018/04/03 13:34
編集2018/04/03 15:13総合スコア33620
0
ベストアンサー
やりかたはいろいろありますが、Rangeオブジェクトに何回もアクセスすると処理が遅くなるので、もし対象データを処理したい場合にはデータをバリアント型変数(配列)に読み込み、処理が完了したらシートに書き戻すようにすると処理が速くなります。
ということで、ご参考まで。
サンプルデータでは(名前×役職)の1組が縦に並んでいたものを、1行に(名前×役職)を3組ずつ並べていますが、下記の実装例では「シート2」の見出し行から、1行に何組ずつ並べれば良いかを自動的に計算しています。
(なので、ちょっとごちゃごちゃしていますが、データ量が多い場合でもかなり高速に処理できるはずです。)
VBA
1Sub narabekae() 2 Dim lngRow1 As Long, lngRow2 As Long, lngCol2 As Long 3 Dim rngData As Range 4 Dim vntSrc As Variant, vntDst As Variant 5 Dim I As Long, J As Long, K As Long 6 7 '-- コピー元データを配列に取り込み 8 With ThisWorkbook 9 With .Worksheets("シート1") 10 '-- 最終行を取得 11 lngRow1 = .Cells(Rows.Count, 1).End(xlUp).Row 12 13 Set rngData = .Range(.Cells(2, 1), .Cells(lngRow1, 2)) 14 vntSrc = rngData.Value2 15 Set rngData = Nothing 16 End With 17 End With 18 19 '-- コピー先シートへデータを貼り付け 20 With ThisWorkbook 21 With .Worksheets("シート2") 22 '-- 最終列を取得 23 lngCol2 = .Cells(1, Columns.Count).End(xlToLeft).Column 24 25 '-- 最終行を計算 26 lngRow2 = Application.WorksheetFunction.RoundUp(2 * lngRow1 / lngCol2, 0) + 1 27 28 '-- コピー先の配列を用意 29 Set rngData = .Range(.Cells(2, 1), .Cells(lngRow2, lngCol2)) 30 vntDst = rngData.Value2 31 32 For I = 1 To lngRow1 - 1 33 J = Application.WorksheetFunction.RoundUp(2 * I / lngCol2, 0) 34 K = 2 * ((I - 1) Mod (lngCol2 / 2)) + 1 35 vntDst(J, K) = vntSrc(I, 1) 36 vntDst(J, K + 1) = vntSrc(I, 2) 37 Next I 38 39 '-- コピー済みデータを書き戻し 40 rngData.Value = vntDst 41 Set rngData = Nothing 42 End With 43 End With 44 45End Sub
バリアント型変数 = Range型変数.Value
で対象のセル範囲を一括で配列変数へ取り込めます。(ちなみに、セル内の値のみを取り込めば良い場合は Value2 にすると、気持ちだけリソースの節約になります。)
処理結果を書き戻す場合は Range型変数.Value = バリアント型変数
で一括で書き戻しできます。
以上、ご参考になれば幸いです。
投稿2018/04/04 16:15
総合スコア5936
0
追記1804032249:質問を見間違えていました。以下のコードは参考にしないでください。
Range.PasteSpecial
でも出来るはずですが、あえて使わない方法を。
ワークシート関数のTRANSPOSEを使用すると、セルの縦横を逆にした配列を取得できます。
それを上手く使うと以下のように書けます。
VBA
1'コピー元の範囲を取得 2Dim srcWs As Excel.Worksheet 3Set srcWs = ThisWorkbook.Worksheets.Item("Sheet1") 4 5Dim srcRng As Excel.Range 6Set srcRng = srcWs.Range("A2:B4") '仮に範囲を決め打ちしています。 7 8'コピー先の左上の角のセルを取得 9Dim destWs As Excel.Worksheet 10Set destWs = ThisWorkbook.Worksheets.Item("Sheet2") 11 12Dim destRootRng As Excel.Range 13Set destRootRng = destWs.Range("A2") 14 15'値を貼り付ける範囲 16Dim destRng As Excel.Range 17Set destRng = destRootRng.Resize(srcRng.Columns.Count, srcRng.Rows.Count) 18 19'値貼り付け 20destRng.Value() = Excel.WorksheetFunction.Transpose(srcRng.Value())
投稿2018/04/03 13:46
編集2018/04/03 13:48総合スコア2166
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
あなたの回答
tips
太字
斜体
打ち消し線
見出し
引用テキストの挿入
コードの挿入
リンクの挿入
リストの挿入
番号リストの挿入
表の挿入
水平線の挿入
プレビュー
質問の解決につながる回答をしましょう。 サンプルコードなど、より具体的な説明があると質問者の理解の助けになります。 また、読む側のことを考えた、分かりやすい文章を心がけましょう。