Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


52110 / 76732 ←次へ | 前へ→

【29463】Re:ワークシート間の検索集計
質問  toki  - 05/10/5(水) 22:21 -

引用なし
パスワード
   ▼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 'はじめの5つ
        mycomPT = comP1.Offset(6, 0).Resize(5, 1).Value '後の5つ
      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 'はじめの5つ
        myhv2 = hv1.Offset(6, 0).Resize(5, 1).Value '2番目の5つ
        myhv3 = hv1.Offset(12, 0).Resize(5, 1).Value '3番目の5つ
        myhv4 = hv1.Offset(18, 0).Resize(5, 1).Value '4番目の5つ
      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 'はじめの5つ
        myten2 = c.Offset(0, 7).Resize(1, 5).Value '次の5つ
        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
0 hits

【28969】ワークシート間の検索集計 toki 05/9/19(月) 23:13 質問
【28972】Re:ワークシート間の検索集計 Statis 05/9/20(火) 9:09 回答
【28996】Re:ワークシート間の検索集計 toki 05/9/20(火) 21:45 お礼
【28995】Re:ワークシート間の検索集計 ponpon 05/9/20(火) 19:25 発言
【28997】Re:ワークシート間の検索集計 toki 05/9/20(火) 21:46 質問
【29000】Re:ワークシート間の検索集計 ponpon 05/9/20(火) 22:52 発言
【29002】Re:ワークシート間の検索集計 toki 05/9/21(水) 7:19 お礼
【29035】Re:ワークシート間の検索集計 ponpon 05/9/22(木) 2:46 発言
【29052】Re:ワークシート間の検索集計 toki 05/9/22(木) 15:21 お礼
【29086】Re:ワークシート間の検索集計 toki 05/9/23(金) 16:56 お礼
【29091】Re:ワークシート間の検索集計 ponpon 05/9/23(金) 21:05 発言
【29096】Re:ワークシート間の検索集計 toki 05/9/23(金) 22:03 質問
【29097】Re:ワークシート間の検索集計 ponpon 05/9/24(土) 0:23 発言
【29099】Re:ワークシート間の検索集計 toki 05/9/24(土) 12:46 お礼
【29104】Re:ワークシート間の検索集計 ponpon 05/9/24(土) 21:40 発言
【29106】Re:ワークシート間の検索集計 toki 05/9/24(土) 23:14 お礼
【29108】Re:ワークシート間の検索集計 ponpon 05/9/25(日) 5:49 発言
【29109】Re:ワークシート間の検索集計 toki 05/9/25(日) 8:27 お礼
【29122】Re:ワークシート間の検索集計 ponpon 05/9/25(日) 16:50 発言
【29126】Re:ワークシート間の検索集計 toki 05/9/25(日) 19:45 質問
【29128】Re:ワークシート間の検索集計 ponpon 05/9/25(日) 21:41 発言
【29188】Re:ワークシート間の検索集計 toki 05/9/27(火) 12:01 質問
【29199】Re:ワークシート間の検索集計 toki 05/9/27(火) 14:21 お礼
【29437】Re:ワークシート間の検索集計 toki 05/10/4(火) 23:08 質問
【29448】Re:ワークシート間の検索集計 Jaka 05/10/5(水) 13:16 発言
【29454】Re:ワークシート間の検索集計 ponpon 05/10/5(水) 18:34 発言
【29463】Re:ワークシート間の検索集計 toki 05/10/5(水) 22:21 質問
【29467】Re:ワークシート間の検索集計 ponpon 05/10/5(水) 22:55 発言
【29526】Re:ワークシート間の検索集計 toki 05/10/6(木) 21:57 お礼
【29529】Re:ワークシート間の検索集計 ponpon 05/10/6(木) 23:34 発言
【29461】Re:ワークシート間の検索集計 toki 05/10/5(水) 22:08 質問
【29462】Re:ワークシート間の検索集計 toki 05/10/5(水) 22:12 発言

52110 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free