| |
▼ponpon さん：
いつもお世話になります。
下記状態で無限ループに入ります。
（本当は4月以降にも各月あるのですが、同じことを記述しているので検証中は削除しています。）
4月シートの状況ですが、J職社員番号8番の人間が1件あります。
そこでJ職を指定して、印刷をかけました。本来だと、J職でオートフィルターがかけられてC列の行を拾って
印刷実行し、終了するはずなのですが、無限印刷に入ります。
※なお下記変数のうちsentakuI には、J職が格納され、erChには社員番号行の”7”が格納されていることをウォッチ式で確認してます。
従って点数集計以降のループの問題だと思うのですがいかがでしょうか？
ponponさんは今までの経緯もご存知と思いますので少し詳細のコードを載せます。
よろしくお願いします。
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 hv1 As Variant
Dim myhv1 As Variant
Dim myhv2 As Variant
Dim myhv3 As Variant
Dim myhv4 As Variant
Dim gyo As Variant
Dim ten As Variant
Dim hvten As Variant
Dim myten1 As Variant, myten2 As Variant
Dim myhvten1 As Variant
Dim myhvten2 As Variant
Dim myhvten3 As Variant
Dim myhvten4 As Variant
Dim mycomiT As Variant
Dim myR As Range
Application.ScreenUpdating = False
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
'職務名、部門名書き出し
Worksheets("人事評価シート").Range("A5").Value = Replace(sentakuP, "Level", "")
Bname = ThisWorkbook.name
Worksheets("人事評価シート").Range("D1").Value = Replace(Bname, ".xls", "")
'社員番号、社員名書き出し
With Worksheets("人事評価シート")
.Range("D3") = c.Offset(0, 0).Value
.Range("D5") = c.Offset(0, -1).Value
End With
'****************************************
'ｺﾝﾋﾟﾃﾝｼｰ項目コピーペースト
'****************************************
With Worksheets(sentakuP)
Set comP1 = .Cells(8, 2) 'ｺﾝﾋﾟﾃﾝｼｰ項目
'項目コピー
mycomP = comP1.Offset(0, 0).Resize(5, 1).Value 'はじめの５つ
mycomPT = comP1.Offset(6, 0).Resize(5, 1).Value '後の５つ
End With
With Worksheets("人事評価シート")
.Cells(13, 1).Offset(0, 0).Resize(5, 1).Value = mycomP
.Cells(19, 1).Offset(0, 0).Resize(5, 1).Value = mycomPT
End With
'****************************************
'ﾋｭｰﾏﾝﾊﾞﾘｭｰ項目コピーペースト
'****************************************
With Worksheets(sentakuV)
Set hv1 = .Cells(8, 2) 'ｺﾝﾋﾟﾃﾝｼｰ項目
'項目コピー
myhv1 = hv1.Offset(0, 0).Resize(5, 1).Value 'はじめの５つ
myhv2 = hv1.Offset(6, 0).Resize(5, 1).Value '2番目の５つ
myhv3 = hv1.Offset(12, 0).Resize(5, 1).Value '3番目の５つ
myhv4 = hv1.Offset(18, 0).Resize(5, 1).Value '4番目の５つ
End With
With Worksheets("人事評価シート")
.Cells(27, 1).Offset(0, 0).Resize(5, 1).Value = myhv1
.Cells(33, 1).Offset(0, 0).Resize(5, 1).Value = myhv2
.Cells(39, 1).Offset(0, 0).Resize(5, 1).Value = myhv3
.Cells(45, 1).Offset(0, 0).Resize(5, 1).Value = myhv4
End With
'****************************************
'マンスリー点数コピーペースト
'****************************************
'4月
With Worksheets("4月")
'点数のコピー
myten1 = c.Offset(0, 2).Resize(1, 5).Value 'はじめの５つ
myten2 = c.Offset(0, 7).Resize(1, 5).Value '次の５つ
mycomiT = c.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
Next
End With
End If
Application.ScreenUpdating = True
End Sub
|
|
toki
- 05/10/5(水) 22:21 -
