| |
▼ponpon さん：
アドバイスありがとうございます。ひとつずつ追っかけてみたところ、やはりFor文が無限ループになっていました。
myRの要素がなくなったらループは終わるかと思ったのですが、空白のままループしてしまうようです。
そこで、
If c.Value = "" Then
Exit For
を入れたところ、うまく抜けられました。
ところで、点数のコピペのところなのですが、変数cを起点に、offsetをかけると、4月単月はよいのですが、5月以降も変数cを起点にすると
4月のデータが張り付いてしまうことがわかりました。
変数cをオブジェクト（セル）として考えていたのですが、あくまでも社員番号の値しか格納できていないような感じでした。
そこで、各月のC列から社員番号の行を拾いだして起点のセルを変数tenにSetしてＲｅｓｉｚｅしたところうまくいきました。
私はどうもコレクションやオブジェクトの捉え方が曖昧なようです・・・
というわけで結果としてはデバッグを細かくやったことで解決？したようです。
もっとうまいやり方があるかもしれませんが、とりあえずアドバイスのおかげで急場はしのげました。
どうもありがとうございました！
Private Sub 職務別印刷上期実行ボタン_Click()
Dim i As Integer, j As Integer
Dim erCh As Variant
Dim comP1 As Variant
Dim mycomP As Variant
Dim mycomPT As Variant
Dim gyo As Variant
Dim ten As Variant
Dim mycomiT As Variant
Dim myR As Range
sentakuI = Replace(sentakuP, "Level", "")
sentakuV = Replace(sentakuP, "Level", "") + "value"
'社員登録がされている職務かどうかのチェック
With Worksheets("4月")
erCh = Application.Match(sentakuI, .Range("A:A"), 0)
End With
If 職務別印刷TextBox1.Value = "" Then
MsgBox "いずれかの職務を選択してください。", vbExclamation, "職務選択": Exit Sub
ElseIf IsError(erCh) Then
MsgBox "この職務の社員登録はありません。", vbExclamation, "登録なし": Exit Sub
Else
'点数集計
'****************************************
'職務によるオートフィルター絞込み
'****************************************
With Worksheets("4月")
'4月A列に職務によるオートフィルターをかける
.Range("A6", "A65536").AutoFilter field:=1, Criteria1:=sentakuI
'抽出されたC列をmyRに格納
Set myR = .Range("C7", "C65536").SpecialCells(xlCellTypeVisible)
'C列を上から順に（C＝社員番号）
For Each c In myR
If c.Value = "" Then
Exit For
Else
'****************************************
'マンスリー点数コピーペースト
'****************************************
'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 '次の５つ
mycomiT = ten.Offset(0, -1).Value 'コミット取り出し
'人事評価シートへ
With Worksheets("人事評価シート")
.Cells(9, 2).Value = mycomiT 'コミット貼り付け
.Cells(13, 2).Resize(5, 1).Value = Application.Transpose(myten1)
.Cells(19, 2).Resize(5, 1).Value = Application.Transpose(myten2)
End With
End With
'オートフィルターの解除
Worksheets("4月").Range("A6", "A65536").AutoFilter
'プリントアウト
Worksheets("人事評価シート").PrintOut
End If
Next
End With
End If
Application.ScreenUpdating = True
End Sub
|
|
toki
- 05/10/6(木) 21:57 -
