Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2010)
横の表を縦に8246行並べ替えたいです。
投稿日時: 20/01/14 16:37:05
投稿者: ALTAKE

EXCELシート上で、セルを範囲指定してコピー後に、コピー先のセル上で[形式を指定して貼り付け]を選択し、画面上の[行列を入れ替える]のチェックボックスに印を入れて実行すると、行と列が入れ替わった表が貼り付けられますよね。
 
このような操作を何千回も繰り返す必要があるのですが、今は1回ずつキーボード操作を行っているのでかなり時間がかかっています。
 
自動的に上記の操作が実行されるようにする方法はありませんでしょうか?
 
sheet1データ
 
 A B C    D E F       G   H I J K L M N O
1 題名     名前1 名前2 名前3・・・・・   名前10 
2項目1
3項目2
4
5
6



31項目31
 
31行O列までで一区切りですこれが8246行まであります。
 
Sheet2
題名 項目1 項目2。。。。。項目31
名前1
名前2



名前10


上記のようにしたいです。
宜しくお願い致します。

回答
投稿日時: 20/01/14 17:57:31
投稿者: WinArrow
投稿者のウェブサイトに移動

マクロの記録という機能で
実際の手操作をコード化することができます。
 
手操作は
31行までの区切り単位を選択して、コピー
別シートを選択して
「形式を選択して貼り付け」ダイアログで
「行列を入れ替える」にチェックを入れて「OK」
という操作をします。
 
1回分操作のコードが作成されるので
選択セル範囲と貼付けセルを変数化するように
コードを修正います。
 

投稿日時: 20/01/14 19:34:15
投稿者: ALTAKE

有難う御座います。
 
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+q
'
    Range("A1:O31").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub
 
1回分を作成しました。
 
Range("A1:O31").Select
 
Range("A1").Select
 
こちらの部分を変数化するということでいいでしょうか。
 
すみません 宜しくお願い致します。

投稿日時: 20/01/14 19:53:03
投稿者: ALTAKE

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+q
'
    Range("A1:O31").Offset(31, 0).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Offset(16, 0).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

End Sub
 
この部分で止まってしまいます。
 
どうしたら良いでしょうか?
 
宜しくお願い致します。

回答
投稿日時: 20/01/14 23:30:02
投稿者: WinArrow
投稿者のウェブサイトに移動

「マクロの記録」は手操作そのままをコードで作成する機能なので
繰り返すなのどは、自分で追加するしかありません。
また、シートの選択、セルお選択もそのままコードになっているため、
シートを跨る処理の場合、画面が切り替わるため、レスポンスがおちます。
 
今回、マクロの記録で作成されたコードは天気作業のエッセンス部分です。
このエッセンス部分を活かした形にするため、
エッセンス部分をサブルーチンとし、
そのサブルーチンを操作する(繰り返し部分)メインを作成します。
 
メインから、複写元セル範囲を引数としてサブルーチンに渡す形とします。
 
↓ は、シートの選択を省き(シートをオブジェクト変数にすることで可能)
メイン〜サブの形式で作成したコードを提示します。
参考にしてください。
 
Option Explicit
 
Private sht1 As Worksheet, sht2 As Worksheet
Private Rowx As Long
Private sht2row As Long
 
Sub MAIN()
    Application.ScreenUpdating = False
    Set sht1 = Worksheets("sheet1")
    Set sht2 = Worksheets("sheet2")
    With sht1
        For Rowx = 1 To 8246 Step 31
            Call TENKI(.Range(.Cells(Rowx, "A"), .Cells(Rowx + 31 - 1, "O")))
        Next
    End With
    MsgBox "転記終了"
End Sub
 
Private Sub TENKI(ByVal sht1Cell As Range)
    With sht2
        sht2row = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
        Debug.Print sht1Cell.Address
        sht1Cell.Copy
        .Cells(sht2row, "A").PasteSpecial _
            Paste:=xlPasteAll, _
            Operation:=xlNone, _
            SkipBlanks:=False, _
            Transpose:=True
    End With
    Application.CutCopyMode = False
End Sub
 
なお、Sheet2側の15行目には、項目行が存在するという推測していますが、
項目行の次の行から貼り付ける仕様になっています。

投稿日時: 20/01/15 09:17:59
投稿者: ALTAKE

有難う御座います。
 
頂いたマクロで出来ました。
 
今日が締め切りだったので大変助かりました。