excel VBA 行列を入れ替えて連続コピペについて、

Writer: admin Type: このテヒョンのiPhone Date: 2018-12-15 00:00
excel VBA 行列を入れ替えて連続コピペについて、もっと効率的なコードを教えてください。転記元(Sheet1) B C D E F (BG列とか続く場合あり)1 H30.1月 社員No 社員No 社員No・ ・ ・2 名前3 売上14 売上25 売上36 計7 H30.2月8 名前9 売上110売上211売上312 計 ・ ・12月まで転記先(Sheet2) A B C D E F1 H30.1月 名前 売上1 売上2 売上3 計2 社員No 氏名 3 社員No 氏名 4 社員No 氏名5 社員No 氏名 ・ ・12月までSheet1の表を月ごとに行列を入れ替えてSheet2に貼り付ける作業があります。これが大量ファイルあるので、なんとか自動化できないか、と以下のコードを色々と調べながら書きました。Sub 行列()Dim i As Long With Worksheets(1) For i = 1 To 68 Step 6 .Range("B" & i & ":B" & i + 5).Copy Worksheets(2).Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlAll _ , Operation:=xlNone, SkipBlanks:=False _ , Transpose:=True .Range("C" & i & ":C" & i + 5).Copy Worksheets(2).Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlAll _ , Operation:=xlNone, SkipBlanks:=False _ , Transpose:=True .Range("D" & i & ":D" & i + 5).Copy Worksheets(2).Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlAll _ , Operation:=xlNone, SkipBlanks:=False _ , Transpose:=True .Range("E" & i & ":E" & i + 5).Copy Worksheets(2).Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlAll _ , Operation:=xlNone, SkipBlanks:=False _ , Transpose:=True .Range("F" & i & ":F" & i + 5).Copy Worksheets(2).Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlAll _ , Operation:=xlNone, SkipBlanks:=False _ , Transpose:=True Next i End WithEnd Subこれで行列入れ替えての連続コピペは出来るのですが、なにせファイルによって列の数のバラつき(社員数の違い)は激しく、.Range("E" & i & ":E" & i + 5).CopyをBG列分までコピペするのも面倒なのです。そこでもっと効率の良いコードはないものかと質問させていただきました。どなたか教えていただけませんでしょうか?共感した0###質問のプログラムを修正するのなら、以下でどうでしょうか。Sub 行列()Dim i As LongDim c As IntegerWith Worksheets(1)For i = 1 To 68 Step 6For c = 2 To .Cells(1, Columns.Count).End(xlToLeft).Column.Range(.Cells(i, c), .Cells(i + 5, c)).CopyWorksheets(2).Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlAll _, Operation:=xlNone, SkipBlanks:=False _, Transpose:=TrueNextNextEnd WithEnd Sub1列毎でなく、全列まとめてコピーする場合です。Sub 行列()Dim i As LongWith Worksheets(1)For i = 1 To 68 Step 6.Range(.Cells(i, 2), .Cells(i + 5, .Cells(1, Columns.Count).End(xlToLeft).Column)).CopyWorksheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=TrueNextEnd WithEnd Subちなみに、最終列(全社員)を1行目で判定していますが、社員数を2行目(名前)で判定する場合は、2つのプログラムの>.Cells(1, Columns.Count).End(xlToLeft).Columnを.Cells(2, Columns.Count).End(xlToLeft).Columnに変更してください。ナイス0
###回答ありがとうございます。Worksheets(2).Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlAll _, Operation:=xlNone, SkipBlanks:=False _, Transpose:=Trueの部分的なのですが、エディターの段階で赤文字になってコードが走らないのはなぜでしょう…。今日、色々試してたのですが解決出来ませんでした。御教授いただければ幸いです。
###ありがとうございました。

 

TAG