NOTE에도 투고했습니다만, 이쪽이 다른 분의 어드바이스를 얻기 쉽다고 느꼈으므로, 전재했습니다. 내용은 약간 수정되어 있습니다.

원래 데이터

매크로 실행 후 데이터

코드

VBA

Sub 月次成績の転記マクロ()

'いくつ変数が必要かわからないため、無数に変数の宣言
Dim i, j, k, l, m, n, o, p, x, y, z As Integer

'###########################################
'#転記元のシートを変えるときの注意事項     #
'#①コピー元のシートの数字を変える。×3か所#
'#②日付の月を変える。×1か所              #
'###########################################

'出力シートで転記開始する行番号の取得
    Sheets("出力用").Activate
    y = getLastRow(Sheets("出力用"), 2)
    z = y + 1 '転記の開始行の番号

'繰り返し回数として、転記元シートのA行において人名が入力されているセルの数を取得
    Sheets("11").Activate '###########################################数字を変える
    x = WorksheetFunction.CountIf(Range("A1:A600"), "*")

'以下は繰り返し処理に係る部分
    For i = 1 To x

'行番号の前計算
    j = i - 1 '調整用
    k = j * 6 '転記元の行数の計算用
    l = j * 31 '転記先の行数の計算用
    m = k + 1 '転記元の氏名の行番号
    n = k + 6 '転記元の範囲の最終行の番号
    o = l + z '転記先の氏名の行番号
    p = l + z + 30 '転記先の氏名オートフィル領域の最終行

'名前のコピー
    Sheets("11").Activate '###########################################数字を変える
    Cells(m, 1).Select
    Selection.Copy
    Sheets("出力用").Activate
    Cells(o, 2).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
'Range("Sheet"出力用"!Cells(m, 1)").Value = Cells(m, 1).Value//挫折している書き方

'名前のオートフィル
    Sheets("出力用").Activate
    Range(Cells(o, 2), Cells(p, 2)).Select
    Application.CutCopyMode = False
    Selection.FillDown
    ActiveWindow.SmallScroll Down:=-21

'日付の入力
    Sheets("出力用").Activate
    Cells(o, 1).Value = DateSerial(2018, 11, 1) '###########################################数字を変える
    Cells(o, 1).Select
    Selection.AutoFill Destination:=Range(Cells(o, 1), Cells(p, 1)), Type:=xlFillDefault

'行列の入れ替えコピー
    Sheets("11").Activate '###########################################数字を変える
    Range(Cells(m, 5), Cells(n, 35)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("出力用").Activate
    Cells(o, 3).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Application.CutCopyMode = False
'    Selection.PasteSpecial Paste:=xlPasteAll,Transpose:=True, Operation:=xlNone,  SkipBlanks:=False,
        Next

End Sub

Function getLastRow(WS As Worksheet, Optional CheckCol As Long = 1) As Long
 With WS
  getLastRow = 0

  If Not Intersect(.UsedRange, .Columns(CheckCol)) Is Nothing Then
   Dim LastRow As Long
   LastRow = .UsedRange.Row + .UsedRange.Rows.Count - 1

   If LastRow > 1 Then
    Dim buf As Variant
    buf = .Range(.Cells(1, CheckCol), .Cells(LastRow, CheckCol)).Value

    Dim C As Long
    For C = UBound(buf, 1) To 1 Step -1
     If Not IsEmpty(buf(C, 1)) Then
      getLastRow = C
      Exit Function
     End If
    Next

   ElseIf Not IsEmpty(.Cells(1, CheckCol).Value) Then
     getLastRow = 1
   End If

  End If
 End With
End Function

개선점

달의 일수에 맞추어 코드를 바꿀 필요가 있다.

이름과 날짜의 자동 채우기의 마지막 행 설정, 복사 영역의 마지막 열 설정이 31이므로 중복 날짜를 삭제해야 아름답지 않다. 하지만 달의 일수를 취득해 그것을 각 요소에 반영시킬 수 없었다.

그리고, 달마다 일일이 코드를 재기록하고 있는 것이 어색하다. 본래는 북내의 시트를 자동으로 읽어 멋대로 전기하도록(듯이) 해야 했다.

원래 시트를 일일이 활성화하고 나서 데이터의 복사와 붙여넣기를 하는 것이 어색하다. 어쩌면 더 우아한 표현이 있었을 것입니다.

게다가, 전기 개시 행의 선택을 위한 펑션으로 1회 마이너스 1 하고 있는데 본류의 코드로 솔레에 1 가산하고 있는 것이 어색하다.

그리고 변수가 너무 많습니다. 원래의 숫자는 각 루프에서 하나이기 때문에 그 변수만으로 쓰는 것이 좋다.