| |
▼ponpon さん：
ponponさんこんばんは。
いつもありがとうございます。
同様のループを考えて試しておりました。コード内容はほぼ同じような構成でやってます。
.Cells(3, 8).End(xlToLeft).Offset(0, 1).Resize(5, 1).Value = Application.Transpose(myTen1)のところなのですが、この場合右側の空白列を順番に各月のデータで埋めていくループになると認識しております。
そうするとヒューマンエラーで万が一、データが残ってしまった場合などを考えると、全部ずれていくような気がしております。
これが原因かはわかりませんが、実際に試している最中に、月がずれてしまう現象が起こりました。
前のデータが残っていたか、消し忘れがあったのかもしれません。
本当は、ループ処理が理想なのですが、今回のマクロは、人事考課用の点数集計表に使用する予定のため間違いが起こらない仕様にしなくてはならないので、各月の各ブロックの第1セルは直接指定することにしました。
そのうえで、ponponさんからの教えに基づきApplication.Transposeを使用して行、列の入れ替え処理をするように改良しています。
ところでApplication.CutCopyMode = Falseとありますが、これはこのソース内でどういった効果があるのでしょうか？
ponponさんのおかげで非常に勉強になりました。
ありがとうございます。
今後ともよろしくお願いします。
現在までの改良ソースです。
非効率な部分があればご指摘ください。
※点数集計表は人事評価シートと表記されています。
※sentakuI はユーザーフォームで職務抽出されている変数です。
Private Sub 職務別印刷上期実行ボタン_Click()
Dim i As Integer, j As Integer
Dim myAry As Variant
Dim gyo As Variant
Dim ten As Variant
Dim hvten As Variant
Dim myten1 As Variant, myten2 As Variant
Application.ScreenUpdating = False
'社員登録がされている職務かどうかのチェック
With Worksheets("4月")
erCh = Application.Match(sentakuI, .Range("A:A"), 0)
End With
If 職務別印刷TextBox1.Value = "" Then
MsgBox "いずれかの職務を選択してください。", vbExclamation, "職務選択"
ElseIf IsError(erCh) Then
MsgBox "この職務の社員登録はありません。", vbExclamation, "登録なし"
Else
'点数集計
'****************************************
'職務によるオートフィルター絞込み
'****************************************
With Worksheets("4月")
'4月A列に職務によるオートフィルターをかける
.Range("A6", .Range("A65536").End(xlUp)).AutoFilter field:=1, Criteria1:=sentakuI
'抽出されたC列をmyRに格納
Set myR = .Range("C7", .Range("C65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
'C列を上から順に（C＝社員番号）
For Each c In myR
'社員番号、社員名書き出し
With Worksheets("人事評価シート")
.Range("D3") = c.Offset(0, 0).Value
.Range("D5") = c.Offset(0, -1).Value
End With
'****************************************
'各月点数コピーペースト
'****************************************
'4月
With Worksheets("4月")
gyo = Application.Match(c, .Range("C:C"), 0)
Set ten = .Cells(gyo, 5)
'点数のコピー
myten1 = ten.Offset(0, 0).Resize(1, 5).Value 'はじめの５つ
myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の５つ
'人事評価シートへ
With Worksheets("人事評価シート")
.Cells(13, 2).Resize(5, 1).Value = Application.Transpose(myten1)
.Cells(19, 2).Resize(5, 1).Value = Application.Transpose(myten2)
End With
End With
'5月
With Worksheets("5月")
gyo = Application.Match(c, .Range("C:C"), 0)
Set ten = .Cells(gyo, 5)
'点数のコピー
myten1 = ten.Offset(0, 0).Resize(1, 5).Value 'はじめの５つ
myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の５つ
'人事評価シートへ
With Worksheets("人事評価シート")
.Cells(13, 3).Resize(5, 1).Value = Application.Transpose(myten1)
.Cells(19, 3).Resize(5, 1).Value = Application.Transpose(myten2)
End With
End With
'6月
With Worksheets("6月")
gyo = Application.Match(c, .Range("C:C"), 0)
Set ten = .Cells(gyo, 5)
'点数のコピー
myten1 = ten.Offset(0, 0).Resize(1, 5).Value 'はじめの５つ
myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の５つ
'人事評価シートへ
With Worksheets("人事評価シート")
.Cells(13, 4).Resize(5, 1).Value = Application.Transpose(myten1)
.Cells(19, 4).Resize(5, 1).Value = Application.Transpose(myten2)
End With
End With
'7月
With Worksheets("7月")
gyo = Application.Match(c, .Range("C:C"), 0)
Set ten = .Cells(gyo, 5)
'点数のコピー
myten1 = ten.Offset(0, 0).Resize(1, 5).Value 'はじめの５つ
myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の５つ
'人事評価シートへ
With Worksheets("人事評価シート")
.Cells(13, 6).Resize(5, 1).Value = Application.Transpose(myten1)
.Cells(19, 6).Resize(5, 1).Value = Application.Transpose(myten2)
End With
End With
'8月
With Worksheets("8月")
gyo = Application.Match(c, .Range("C:C"), 0)
Set ten = .Cells(gyo, 5)
'点数のコピー
myten1 = ten.Offset(0, 0).Resize(1, 5).Value 'はじめの５つ
myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の５つ
'人事評価シートへ
With Worksheets("人事評価シート")
.Cells(13, 7).Resize(5, 1).Value = Application.Transpose(myten1)
.Cells(19, 7).Resize(5, 1).Value = Application.Transpose(myten2)
End With
End With
'9月
With Worksheets("9月")
gyo = Application.Match(c, .Range("C:C"), 0)
Set ten = .Cells(gyo, 5)
'点数のコピー
myten1 = ten.Offset(0, 0).Resize(1, 5).Value 'はじめの５つ
myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の５つ
'人事評価シートへ
With Worksheets("人事評価シート")
.Cells(13, 8).Resize(5, 1).Value = Application.Transpose(myten1)
.Cells(19, 8).Resize(5, 1).Value = Application.Transpose(myten2)
End With
End With
'プリントアウト
Worksheets("人事評価シート").PrintOut
Next
'オートフィルターの解除
.Range("A6", .Range("A65536").End(xlUp)).AutoFilter
End With
|
|
toki
- 05/9/24(土) 23:14 -
