Excel VBA 質問スレッド No.15 (未解決)

空白セルまでのコピーと横方向のデータを縦方向にするコード

投稿者 : あき     投稿日時 : 2016/11/27(Sun) 23:36:55     OS : Windows 10     EXCEL : Excel 2013
はじめまして。急ぎで教えていただきたくこちらの掲示板をお借りました。
2点あります。元表の形を変えて基幹システムに投入します。何卒よろしくお願いいたします。

【元表の形式】
A:NO. B:会員番号 C:氏名 D:講座A E:講座B F:講座C
※D列~F列の講座には受講日が入っています。
講座を縦向けにしたいです。

【変更後】
A:NO. B:会員番号 C:氏名 D:講座名 E:日付
1     12345   田中  講座A  11/2
1     12345   田中  講座B  
1     12345   田中  講座C  11/5
2     45678   山本  講座A
2     45678   山本  講座B  11/2
2     45678   山本  講座C  11/3

【質問1】
行挿入のコードは何とかできました。
そのときに上に2行挿入されます。
A3~C3の項目を上方向に2行コピーしたいです。
そのとき、データの一番下の行までコピーをしたいのですが、
間に空白セルが入っているため、本当の表最下段を認識してくれず、困っています。
以下は自動マクロでコピーしただけです。

sub macro1()
Range("A49:D49").Select
Selection.Copy
Range("A42:D48").Select
ActiveSheet.Paste
Range("A57:D57").Select
Application.CutCopyMode = False
Selection.Copy
Range("A50:D56").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=15
Range("A65:D65").Select
Application.CutCopyMode = False
Selection.Copy
Range("A58:D64").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=9
Range("A73:D73").Select
Application.CutCopyMode = False
Selection.Copy
Range("A66:D72").Select
ActiveSheet.Paste
Range("A81:D81").Select
Application.CutCopyMode = False
Selection.Copy
Range("A74:D80").Select
ActiveSheet.Paste
Range("A89:D89").Select
Application.CutCopyMode = False
Selection.Copy
Range("A82:D88").Select
ActiveSheet.Paste
Range("A97:D97").Select
Application.CutCopyMode = False
Selection.Copy
Range("A90:D96").Select
ActiveSheet.Paste
End Sub

【質問2】
元表のD列~F列を縦方向にするために、自動マクロで縦横を入れ替えるで別場所でコピーをして
E列に貼り付けましたが、これも表の最下段を認識してくれないので、どのように指定したらよいか悩んでいます。(以下、少しセル参照が異なります。)

Sub Macro2()
Range("F25:M25").Select
Selection.Copy
Range("N18").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("F33:M33").Select
Application.CutCopyMode = False
Selection.Copy
Range("N26").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=6
Range("F41:M41").Select
Application.CutCopyMode = False
Selection.Copy
Range("N34").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=9
Range("F49:M49").Select
Range("M49").Activate
Application.CutCopyMode = False
Selection.Copy
Range("N42").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=9
Range("F57:M57").Select
Application.CutCopyMode = False
Selection.Copy
Range("N50").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=9
Range("F65:M65").Select
Application.CutCopyMode = False
Selection.Copy
Range("N58").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("F73:M73").Select
Application.CutCopyMode = False
Selection.Copy
Range("N66").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=12
Range("F81:M81").Select
Application.CutCopyMode = False
Selection.Copy
Range("N74").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=9
Range("F89:M89").Select
Application.CutCopyMode = False
Selection.Copy
Range("N82").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=9
Range("F97:M97").Select
Application.CutCopyMode = False
Selection.Copy
Range("N90").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=-57
Range("N18:N97").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=-60
Range("F18").Select
ActiveSheet.Paste
Range("G16:O101").Select

[返信 1] Re : 空白セルまでのコピーと横方向のデータを縦方向にするコード
投稿者 : 管理人     投稿日時 : 2016/11/28(Mon) 22:20:48
自動マクロの内容はよくわかりませんが、
元表の内容を変更後の形式で別シートに出力するマクロを作りましたので、
これでよければ使ってみてください。

このマクロの前提としては、
元のデータは「元表」シートにあり、
同じブック内に「変更後」シートが必要になります。


Sub macro1()

Dim ws1, ws2 As Worksheet
Dim row1, row2 As Integer
Dim col1 As Integer

Set ws1 = Worksheets("元表") ' 元データのシート名
Set ws2 = Worksheets("変更後") ' 変更後データのシート名


row1 = 2 ' 元表の明細開始行
row2 = 2 ' 変更後表の明細開始行


' 明細開始行からNoが空白になるまでループ
Do Until ws1.Cells(row1, 1).Value = ""

' 講座A-Cを各行に展開
For col1 = 4 To 6

ws2.Cells(row2, 1).Value = ws1.Cells(row1, 1).Value ' NO
ws2.Cells(row2, 2).Value = ws1.Cells(row1, 2).Value ' 会員番号
ws2.Cells(row2, 3).Value = ws1.Cells(row1, 3).Value ' 氏名

Dim kozaName As String
Select Case col1
Case 4: kozaName = "講座A"
Case 5: kozaName = "講座B"
Case 6: kozaName = "講座C"
Case Else: kozaName = "講座X"
End Select

ws2.Cells(row2, 4).Value = kozaName ' 講座名
ws2.Cells(row2, 5).Value = ws1.Cells(row1, col1).Value ' 講座日付

row2 = row2 + 1

Next col1


row1 = row1 + 1
Loop

End Sub

[返信 2] Re : 空白セルまでのコピーと横方向のデータを縦方向にするコード
投稿者 : あき     投稿日時 : 2016/11/29(Tue) 11:10:55
わかりやすいご回答をいただきまして、誠にありがとうございました。
知識が足らず、うまく実行できないため、再度質問させてください。
申し訳ございません。そして、よろしくお願いいたします。

【質問1】
情報を24行飛ばしで最終行までコピーしたい。
今は以下の様にA25~J25のデータをoffsetで23行上、22行上、と最後は1行上まで作成しています。これだとA25~J25のデータしかコピーされませんが、
次に49行目、73行目と24行ごとにデータがあり、上方向に23行コピーして、
なおかつ、下方向に表の最終行までコピーしたいと思っています。

Sub 情報コピー()

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-23, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-22, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-21, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-20, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-19, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-18, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-17, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-16, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-15, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-14, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-13, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-12, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-11, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-10, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-9, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-8, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-7, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-6, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-5, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-4, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-3, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-2, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A25:j25").Select
Selection.Copy
ActiveCell.Offset(-1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

End Sub


【質問2】
L25~AI25に入っている日付をL2~L25まで縦方向に移動(コピーでも大丈夫です。)して、24行おきに同じ動作を実行したいです。
現在は以下のとおり、一つずつ移動することを自動マクロにしていますが、
これを下方向に表の最終行までコピーしたいです。

Sub 移動()

Range("L1").Select
Selection.Cut
Range("K2").Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("M1").Select
Selection.Cut
Range("K3").Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("N1").Select
Selection.Cut
Range("K4").Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("O1").Select
Selection.Cut
Range("K5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
    ・
    ・
    ・
end sub

[返信 3] Re : 空白セルまでのコピーと横方向のデータを縦方向にするコード
投稿者 : 管理人     投稿日時 : 2016/11/30(Wed) 23:25:34
おそらくFor文などの構文すらも理解していないようで、
回答しても理解してもらえないような気がしますが、
一応以下に回答します。


【質問1の回答】
上記の100行以上におよぶ情報コピー処理はレンジのCopyメソッドで簡単に記述することができます。
最終行の終了判定については、コピー元データ内に空白を含むかどうかによりますが、
とりあえず先頭セルが空白になるまでループ処理としました。

Sub 情報コピー2()

Dim rngSrc As Range

' コピー開始行
Set rngSrc = Range("A25:J25")

' コピー元行の先頭セルが空白になるまでループ
Do Until rngSrc.Cells(1, 1).Value = ""

' コピー元行を上23行に一括コピー
rngSrc.Copy rngSrc.Offset(-23, 0).Resize(23, rngSrc.Cells.Count)

' コピー元行を24行下へ移動
Set rngSrc = rngSrc.Offset(24, 0)

Loop

End Sub




【質問2の回答】
値だけ移動する例です。(書式は対象外)
ループ終了判定は上記と同じ扱いにしています。

Sub 移動2()

Dim rngSrc As Range
Dim rngDist As Range
Dim i As Integer

' 移動元
Set rngSrc = Range("L25:AI25")
' 移動先
Set rngDist = Range("L2:L25")

' 移動元レンジの先頭セルが空白になるまでループ
Do Until rng.Cells(1, 1).Value = ""

' 移動(値だけコピーして、コピー元をクリア)
For i = 1 To rngSrc.Cells.Count
rngDist.Cells(i).Value = rngSrc.Cells(i).Value
rngSrc.Cells(i).Value = ""
Next i

' 移動元、移動先を24行下へ移動
Set rngSrc = rngSrc.Offset(24, 0)
Set rngDist = rngDist.Offset(24, 0)

Loop

End Sub

スポンサード リンク
 
 
当掲示板について
返信入力フォーム
お 名 前  :
内  容   :
ステータス  : この質問を解決済みにする

認証コード  :
        キャプチャ画像


( 処理日時 : 2019-08-26 09:44:51 )

Page
Top