Excel VBA質問箱 IV

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

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


9068 / 13644 ツリー ←次へ | 前へ→

【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 発言[未読]

【28969】ワークシート間の検索集計
質問  toki  - 05/9/19(月) 23:13 -

引用なし
パスワード
   こんにちは。tokiです。

【28685】チェックボックスからの質問の続きなのですが、質問の内容がチェックボックスとは性質が異なるため別スレッドにてご質問させていただきます。
よろしくお願いいたします。

皆様のご助言により新たな仕様で印刷方法を考えております。

1月〜12月までのワークシートがあります。
それにはそれぞれ、職務、社員番号、社員名及び点数10項目が記載されています。

印刷方法としてユーザーフォームにおいて一括印刷を検討しています。
職務を選択すると、該当する職務の複数の人間について、1月〜12月までの点数がワークシート(”集計表”)に反映され、人数分の集計表が印刷されるというしくみです。

各月のワークシートは、
A列  B列   C列    D列  E列  F列 ・・・・
職務 氏名 社員番号 点数A 点数B 点数C・・・・
S   ○○ ○○○○  ○    ○   ○
M   ○○ ○○○○  ○    ○   ○
S   ○○ ○○○○  ○    ○   ○  
S   ○○ ○○○○  ○    ○   ○
M   ○○ ○○○○  ○    ○   ○
M   ○○ ○○○○    
J   ○○ ○○○○    
J   ○○ ○○○○    
S   ○○ ○○○○    

という具合です。

仕様としては、まずA列を「S職」などの職務で検索しS職の人間の点数10項目をワークシート集計表の10個のセルに
代入していく予定です。
集計表のフォーマットは

点数 1月 2月 3月 4月 ・・・・・・・・
A   ○  ○  ○  ○
B   ○  ○  ○  ○
C   ○  ○  ○  ○
D   ○  ○  ○  ○
E   ○  ○  ○  ○
F


という具合です。

この場合、各月のワークシートでの職務の抽出は、
1.myRow=Application.Match(S職.Range("A:A"), 0)
の戻り値を使用し.Cells(myRow, "A").Offset(0, 3).Valueなどで各点数を変数として取得し、集計表のセルにRange単位で代入すればよいのでしょうか?
だとすると、各月のワークシートの全てのS職に対して上から順番に繰り返し処理を行い、かつ印刷をかけるにはどのようなコードにすればよいのでしょうか?

2.1月〜12月までのワークシートに、点数以外の各社員データを登録する場合はユーザーフォームから各シートに一斉に書き込んでいます。なので、行構成は各シート共通となっているはずなのですが、念の為、S職などの職務を抽出した後、社員番号で引き当てていきたいと思っています。
この場合、例えば、ユーザーフォームからの検索対象のワークシートを1月と仮定すると、1月で職務の検索を行い、最初のS職の処理で、offset(0,2)で社員番号を拾い、2月以降の点数の引当は、社員番号で行う、という処理は可能でしょうか?

【28972】Re:ワークシート間の検索集計
回答  Statis  - 05/9/20(火) 9:09 -

引用なし
パスワード
   こんにちは

1,に関してMatch関数で行を取得して点数はコピー&ペースト(列行の入れ替え)
 で出来ますね。(変数に代入でも出来ますが)
2,念の為なら、職務と社員番号の2つで確認したほうが良いのではないですか?
 可能か如何かと言うと、可能です。

【28995】Re:ワークシート間の検索集計
発言  ponpon  - 05/9/20(火) 19:25 -

引用なし
パスワード
   こんばんは。
仕様の変更をされたようで何よりです。

さて、本題ですが、

>仕様としては、まずA列を「S職」などの職務で検索しS職の人間の点数10項目をワークシ>ート集計表の10個のセルに
>代入していく予定です。
>集計表のフォーマットは

>点数 1月 2月 3月 4月 ・・・・・・・・
>A   ○  ○  ○  ○
>B   ○  ○  ○  ○
>C   ○  ○  ○  ○
>D   ○  ○  ○  ○
>E   ○  ○  ○  ○
>F
>・
>・
>という具合です。

これの意味がよく分からないのですが・・・
グループ(職務)ごとに集計するのですか?
それとも個人ごとに集計シートを作成し、集計するのですか?

>各月のワークシートでの職務の抽出は

オートフィルターで各職が抽出できると思います。

仕様がいまいち分からないので・・・

各シートA列でソート、その後C列でソートすると、
各職ごと、社員番号順に並び替えができると思います。
それから、集計の方法を考えられたらいかがでしょう?

【28996】Re:ワークシート間の検索集計
お礼  toki  - 05/9/20(火) 21:45 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>
>1,に関してMatch関数で行を取得して点数はコピー&ペースト(列行の入れ替え)
> で出来ますね。(変数に代入でも出来ますが)
>2,念の為なら、職務と社員番号の2つで確認したほうが良いのではないですか?
> 可能か如何かと言うと、可能です。

ご回答ありがとうございます。
列行の入れ替えというのがよくわからないのです。
offsetを使用するのでしょうか?

【28997】Re:ワークシート間の検索集計
質問  toki  - 05/9/20(火) 21:46 -

引用なし
パスワード
   ▼ponpon さん:
ponponさんこんばんは。いつもありがとうございます。

仕様は個人ごとに集計シートを作成します。

ご理解いただくためにシステム概要について詳しくご説明します。

例えば、社員が田中、鈴木、佐藤、井上、吉田の5名がいるとします。

田中 S職 社員番号1
鈴木 M職 社員番号2
佐藤 J職 社員番号3
井上 S職 社員番号4
吉田 J職 社員番号5

3名の点数を毎月つけていき、6ヶ月ごとに集計シートで集計結果を出力します。

【社員登録の仕方】
初月を4月とし、年度末を3月とします。

1月〜12月までの入力用ワークシートがあり、それぞれのワークシートには、職務、氏名、社員番号、点数の入力欄が列ごとに配置してあります。
これらの社員データは、行単位で管理され、ユーザーフォームにて社員登録フォームがあり、こちらで職務、氏名、社員番号を入力すると、新しい行が追加される、というようになっています。

※月別ワークシート例

職務 氏名 社員番号 点数A 点数B 点数C 点数D・・・・(←見出し部分)
S職 田中   1
M職 鈴木   2
J職 佐藤   3
S職 井上   4
J職 吉田   5

この登録フォームから登録された社員データ(点数を除く)は、1月〜12月までのワークシートに同時に作成されます。

登録の段取りですが、職務別に行うわけではありません。職務的には順不同で登録していきます。
したがって、登録順に上から順番に行が追加されていくため、ワークシート上には職務がバラバラの状態で、登録されていきます。
後で点数をつけるときに職務ごとに整列していた方がやりやすいため、前回ご質問させていただいた「整列ボタン」をワークシート上に置き、このボタンを押すと、職務ごとに整列するようにしてあります。
この整列も、ワークシート1月〜12月までのすべてが連動するようにしてあります。

【点数のつけ方】
得点対象の種類は10個あります。毎月発生するので、各月ごとに手入力していきます。

例えば、4月に各人の10種類の点数がはじき出されるので、それを

     点数A  点数B  点数C  点数D・・・・
田中   5     3     2      3
鈴木   3     3     3      4
佐藤   4     3     2      5
井上   5     2     1      2
吉田   3     3     2      4

というようにワークシート上で手入力していきます。

この作業を他の各月に対しても行います。

【集計の仕方】
各月の点数入力が終わると、得点集計がされることになります。

別に用意された点数集計シートにて個人ごとの集計が行われます。

※点数集計表概略

・・・・・・・・・・・・・・・・・    <点数集計表>・・・・・・・・・・・・・・・・・・・・
S職 社員番号1 田中

見出し    4月 5月 6月 7月 8月 9月  6ヶ月平均

点数A   5   3   3  2   3   1    2.8
点数B   3   2   3  1   2   2    2.1
点数C   2   2   2  2   1   2    1.3
点数D   3   3   4  4   3   2    3.1
点数E

見出し   4月 5月 6月 7月 8月 9月  6ヶ月平均

点数F
点数G
点数H
点数I
点数J
・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・

これらの集計のタイミングですが、印刷ボタンを実行したときに集計〜印刷までの
流れをコーディングしたいと思っています。

具体的には、ユーザーフォームにて職務別一括印刷画面を作成し、

1.リストボックスから、印刷対象職務を選択する。
2.印刷実行
3.対象職務者全員に対し、順番に各月集計〜印刷を実行していく。
4.対象職務者の印刷が終わって終了

例えば
1.S職を選択
2.印刷実行
3.田中さん、井上さんを集計のうえ印刷
4.終了

という流れです。

私がよくわからないのは
1.S職を選択
のところで、ユーザーフォームで選択したS職を各月シートのA列を検索し、S職田中さんを見つけ出したうえで
対応する行にある点数を抜き取り、点数集計表の「対応月」に貼り付ける、というところです。
この貼り付け作業を4月〜9月について行わなくてはなりません。

この抜き取り作業時に、念の為、処理中のS職、田中、社員番号1に関して、検索対象を4月シートにした場合、それ以外のシートは、対応する社員番号をキーとして抜き取り行を絞れればよいかと思っています。
ただ、私にはこの連携の仕方が考えつきません。

※ちなみに点数集計表は上図のように「見出し」が間に入ってます。

また、各点数に変数を用意して代入していくことも考えましたがかなりの変数量になるので行単位、列単位での処理ができないか、とも思っています。

もちろん田中さんが終わったあとは続けて、井上さんを拾い出し、同じ処理をします。

このS職対応者全員に関する繰り返し処理がよくわかりません。

以上なのですが、ご理解いただけましたでしょうか?

不明な点等ありましたらまたご指摘ください。
よろしくお願いします。

【29000】Re:ワークシート間の検索集計
発言  ponpon  - 05/9/20(火) 22:52 -

引用なし
パスワード
   こんばんは。

私も初心者に毛の生えたようなもので、自分の勉強のために
回答をわかる範囲でしています。従ってミスも多いです。
そのことを踏まえて

tokiさんからの課題を考えるに当たって
作業を分離していきます。
大きく分けると、集計表に転記の部分と印刷の部分になると思います。
そこで、 
 (1)ユーザーフォームは後でも出来るので後回し。
 (2)印刷は、別プロシージャにして、Callで呼び出すので後回し。
 (3)一つの職種が出来れば後は、職種毎に繰り返し。
 (4)一月分が出来れば、後は転記先を変えるだけ(offset)で同じ事の繰り返し。
 (5)一人分が出来れば、後は人を変えて同じ事
 (6)ということは、一つの職種の一月分の一人分を考えればよい。

ということになろうかと思います。
考える順番は、(6)→(5)→(4)→(3)→(2)→(1)かな?
もちろん、転記の全体的なイメージは持ちながらですが、

 (6)を考えるには、
  まず、各シートのデータが一括で入力されていることから、
  データ数は同じ、それならA列とC列でソートすれば、どのシートも
  データが職務別に、社員番号の若い順に並んでいるはずですよね。

  オートフィルターを使って、職務で抽出する。
  一番上のデータから必要な列データを集計表シートに転記 
  
  これが出来たら、シートを追加しながら(シート名は氏名か社員番号)、
  上から順番に転記

と考え、マクロの記録やヘルプや過去ログを参考に作っていきます。

でも、個人毎に集計とは、人数分シートが出来るわけですよ。
100人いたら100枚のシートが。

今日は、明日までの仕事があり、考える時間がないので、考え方だけで悪いのですが・・・
上級者は、もっと違った方法を考えるかもしれません。それでは。

【29002】Re:ワークシート間の検索集計
お礼  toki  - 05/9/21(水) 7:19 -

引用なし
パスワード
   ▼ponpon さん:
ありがとうございます!

とりあえず、ponponさんの考え方を元にやってみます。
またよろしくお願いします。

【29035】Re:ワークシート間の検索集計
発言  ponpon  - 05/9/22(木) 2:46 -

引用なし
パスワード
   こんばんは。
もう見てないかもしれませんが・・・
個人集計表に一応転記するところまで作ってみました。
エラー処理はしていません。
上級者には、笑われるかもしれませんが・・・・
もっと簡単で良い方法があったら、アドバイスしてください。

前提
 今回は、4月から9月までの9枚のシートがあるものとし、
 シートレイアウトは、提示されているものとします。
 シート名は、全角の"4月"から"9月"

20人位で試しましたが、人数が増えると時間がかかると思います。
PEN42.6G、WinXPで1秒程度
以下コードです。試して見てください。

Sub test()
  Dim myR As Range, myR2 As Range, c As Range
  Dim myVal As Variant, myVal2 As Variant, SHNAME As Variant, myARy As Variant
  Dim SH As Worksheet, NewSH As Worksheet
  Dim Midasi As Variant
  Dim i As Integer, j As Integer, t As Integer

  Application.ScreenUpdating = False

'***************************************************
'月ファイル以外削除・・1回だけのの実施なら必要なし
'***************************************************
  For Each SH In Worksheets
   If SH.Index > 6 Then '4月から9月までの6枚のシートがあるとして、
    Application.DisplayAlerts = False  '7枚目以降は個人シート
    SH.Delete              'だから削除
    Application.DisplayAlerts = True
   End If
  Next
 
  '*************************************************
  'シート(4月)から氏名を抽出し、氏名シートの作成
  '*************************************************
  With Worksheets("4月")
  
   '点数のところの見出しを格納
   Midasi = .Cells(1, 4).Resize(1, 13).Value
  
   'A1のCurrentRegionをmyRにセット
   Set myR = .Range("A1").CurrentRegion
  
   'myRを職種と、社員番号でソート
   myR.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range( _
    "C2"), Order2:=xlAscending, Header:=xlGuess
  
   'シート名になる氏名をSHNAMEに格納
   SHNAME = .Range("B2", .Range("B65536").End(xlUp)).Value
  
   '新しいシートを追加し、シート名を氏名にし、A2に「月」を
   For t = 1 To UBound(SHNAME, 1) 'A3から下に点数の見出しを入れる。
    Set NewSH = Worksheets.Add(after:=Sheets(Sheets.Count))
    With NewSH
     .Name = SHNAME(t, 1)
     .Cells(2, 1).Value = "月"
     .Cells(3, 1).Resize(10, 1).Value = Application.Transpose(Midasi)
    End With
   Next
  End With
 
  '***************************************
  'シート4月から9月までデータの取り出し
  '***************************************
  myARy = Array("4月", "5月", "6月", "7月", "8月", "9月") '全角 シート名も全角で
  For i = 0 To UBound(myARy)
    '4月から順に9月のシートまで
    With Worksheets(myARy(i))
   
     '範囲をセットし、A列・C列でソート
     Set myR = .Range("A1").CurrentRegion
     myR.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range( _
     "C2"), Order2:=xlAscending, Header:=xlGuess
     
     'A列を重複なしでAA列に書き出す。
     myR.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AA1"), Unique:=True
     
     'AA列の2行目から終わりまでをmyValに格納
     myVal = .Range("AA2", .Range("AA65536").End(xlUp)).Value
   
     '職種毎に
     For j = 1 To UBound(myVal, 1)
      
       'オートフィルターをかける
       myR.AutoFilter field:=1, Criteria1:=myVal(j, 1)
      
       '抽出されたB列をmyR2に格納
       Set myR2 = .Range("B2", .Range("B65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
      
'       B列を上から順に
       For Each c In myR2
        
        '点数の部分だけをコピーして
        c.Offset(0, 2).Resize(1, 10).Copy
        
        'B列(氏名)と同じシートに
        With Worksheets(c.Text)
         
         '職種・氏名・社員番号の書き出し
         If IsEmpty(.Cells(1, 1).Value) Then
         .Cells(1, 1).Resize(1, 3).Value = c.Offset(0, -1).Resize(1, 3).Value
         End If
         
         '2行目に月名を入れて
         .Cells(2, 256).End(xlToLeft).Offset(0, 1).Value = myARy(i)
         
         'コピーしていた点数を行列を入れ替えて貼り付け
         .Cells(3, 256).End(xlToLeft).Offset(0, 1).PasteSpecial Transpose:=True
        End With
       Next '次の人へ
      
       'オートフィルターの解除
       myR.AutoFilter
     
     Next '次の職種へ
     
     '一時利用したAA列の削除
     .Range("AA:AA").ClearContents
    End With
  
  Next '次の月へ
  
  '***************
  '平均値の挿入
  '***************
  '月ファイルが6枚なので、Indexが7から終わりまでが個人シート
  For t = 7 To Sheets.Count
   
    '個人シートに
    With Worksheets(t)
      With .Cells(2, 256).End(xlToLeft)
     
       '2行目の一番最後に「6ヶ月平均」を入力
       .Offset(0, 1).Value = "6ヶ月平均"
      
       'その下から10行に平均値を入力
       .Offset(1, 1).Resize(10, 1).Value = "=AVERAGE(RC[-6]:RC[-1])"
      End With
    End With
   Next
  
  With Application
     .CutCopyMode = False
     .ScreenUpdating = True
  End With
End Sub

【29052】Re:ワークシート間の検索集計
お礼  toki  - 05/9/22(木) 15:21 -

引用なし
パスワード
   ▼ponpon さん:
ponponさんこんにちは!!
もちろん見てますよ!

ご教示ありがとうございます。
本日は仕事が遅いので、明日試してみます!!結果はまたご報告します!

【29086】Re:ワークシート間の検索集計
お礼  toki  - 05/9/23(金) 16:56 -

引用なし
パスワード
   ▼ponpon さん:
ponponさんこんにちは。

いろいろと試してみました!

まず、仕様についてですが、個人ごとに点数集計シートを「新規ワークシート」としては作成しないつもりです。
私の説明の仕方がまずかったのですが、個人ごとの集計シートは「印刷」のみ行います。

また、職務→社員番号の整理(Sort)については、社員登録の際に、ユーザーフォームの登録ボタンを実行すると、登録

時に整理用のマクロが起動するようにしました。
このマクロで社員番号Keyを追加し連続Sortしています。

問題は4月〜9月までのデータの取り出しと、点数集計表への貼り付け印刷なのですが、ponponさんのマクロですと

CurrentRegionが使用されています。
私も詳しくないのですが、CurrentRegionは保護されたワークシート上ではErrorを出すと読んだことがあります。
今回、集計以外の見出しの部分などを保護する予定なので使用を避けようかと思いますがいかがでしょう?

>  '***************************************
>  'シート4月から9月までデータの取り出し
>  '***************************************
>  myARy = Array("4月", "5月", "6月", "7月", "8月", "9月") '全角 シート名も全角で
>  For i = 0 To UBound(myARy)
>    '4月から順に9月のシートまで
>    With Worksheets(myARy(i))


●登録ボタンでA列・C列は整理済のため、この部分は不要でしょうか?
  
>     '範囲をセットし、A列・C列でソート
>     Set myR = .Range("A1").CurrentRegion
>     myR.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range( _
>     "C2"), Order2:=xlAscending, Header:=xlGuess


●AA列というのは一時的に仮置きで使用しているということでしょうか?目的は職務の種類(例えばJ,S,M)の抽出でよろしいでしょうか?
    
>     'A列を重複なしでAA列に書き出す。
>     myR.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AA1"), Unique:=True
>     'AA列の2行目から終わりまでをmyValに格納
>     myVal = .Range("AA2", .Range("AA65536").End(xlUp)).Value

だとすると、ユーザーフォームでの職務選択時に職務を取得できるのでそれを利用しようと思います。

●行列の入れ替えですが、行を列にするときに、仕様上見出しが列の真中にも入るため変数を使用せざるを得ないような気がします。
ponponさんのを改造して下記のようなマクロにしたら、うまく動きました。
ちなみにsentakuPにはすでにワークシート名が格納されています。
※マクロ中の変数はpublic宣言済みのものもあります。

'点数集計
Dim sentakuP As Variant
Dim sentakuV As Variant
Dim sentakuI As Variant
Dim myRow4 As Variant
Dim myRow5 As Variant
Dim myRowten As Variant
Dim myR As Range
Dim c As Range
  
  sentakuI = Replace(sentakuP, "Level", "")
  
  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列を上から順に
    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月")

        myRow4 = Application.Match(c, .Range("C:C"), 0)
          comp1_4 = .Cells(myRow4, "C").Offset(0, 2).Value
          comp2_4 = .Cells(myRow4, "C").Offset(0, 3).Value
          comp3_4 = .Cells(myRow4, "C").Offset(0, 4).Value
          comp4_4 = .Cells(myRow4, "C").Offset(0, 5).Value
          comp5_4 = .Cells(myRow4, "C").Offset(0, 6).Value
          comp6_4 = .Cells(myRow4, "C").Offset(0, 7).Value
          comp7_4 = .Cells(myRow4, "C").Offset(0, 8).Value
          comp8_4 = .Cells(myRow4, "C").Offset(0, 9).Value
          comp9_4 = .Cells(myRow4, "C").Offset(0, 10).Value
          comp10_4 = .Cells(myRow4, "C").Offset(0, 11).Value
      End With
          
      With Worksheets("点数集計シート")
            .Range("B13") = comp1_4
            .Range("B14") = comp2_4
            .Range("B15") = comp3_4
            .Range("B16") = comp4_4
            .Range("B17") = comp5_4
            .Range("B19") = comp6_4
            .Range("B20") = comp7_4
            .Range("B21") = comp8_4
            .Range("B22") = comp9_4
            .Range("B23") = comp10_4
       End With
      '点数をコピー5月分
      With Worksheets("5月")
        myRow5 = Application.Match(c, .Range("C:C"), 0)

          comp1_5 = .Cells(myRow5, "C").Offset(0, 2).Value
          comp2_5 = .Cells(myRow5, "C").Offset(0, 3).Value
          comp3_5 = .Cells(myRow5, "C").Offset(0, 4).Value
          comp4_5 = .Cells(myRow5, "C").Offset(0, 5).Value
          comp5_5 = .Cells(myRow5, "C").Offset(0, 6).Value
          comp6_5 = .Cells(myRow5, "C").Offset(0, 7).Value
          comp7_5 = .Cells(myRow5, "C").Offset(0, 8).Value
          comp8_5 = .Cells(myRow5, "C").Offset(0, 9).Value
          comp9_5 = .Cells(myRow5, "C").Offset(0, 10).Value
          comp10_5 = .Cells(myRow5, "C").Offset(0, 11).Value
      End With
          
      With Worksheets("点数集計シート")
            .Range("C13") = comp1_5
            .Range("C14") = comp2_5
            .Range("C15") = comp3_5
            .Range("C16") = comp4_5
            .Range("C17") = comp5_5
            .Range("C19") = comp6_5
            .Range("C20") = comp7_5
            .Range("C21") = comp8_5
            .Range("C22") = comp9_5
            .Range("C23") = comp10_5
       End With
    
    'プリントアウト
    Worksheets("点数集計シート").PrintOut
    
    Next
    'オートフィルターの解除
    .Range("A6", .Range("A65536").End(xlUp)).AutoFilter
  End With

●結局点数集計シートの各月の入力セル(列)が異なるため、4月シートを基礎として抽出した印刷対象者について、全月の貼り付け作業をを実行していくしかないわけですよね?
つまり対象者ごとにワークシートを作成するわけではないので、各月ごとの繰り返し処理ではなく、ひとりひとり印刷実行までの処理を終わらしていかないといけないので・・・

●それと平均値の件ですが、ワークシート側に数式を入れてありますのでVBAでの操作は基礎データの入力まで、としました。

以上、ponponさんのソースが非常に参考になりました。
改めて御礼申し上げます。
もう少しいろいろと試してみますので、またよろしくお願いします!

【29091】Re:ワークシート間の検索集計
発言  ponpon  - 05/9/23(金) 21:05 -

引用なし
パスワード
   ▼toki さん:

こんばんは。

>●登録ボタンでA列・C列は整理済のため、この部分は不要でしょうか?
 それなら、いらないですね。

>  
>>     '範囲をセットし、A列・C列でソート
>>     Set myR = .Range("A1").CurrentRegion
>>     myR.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range( _
>>     "C2"), Order2:=xlAscending, Header:=xlGuess
>
>
>●AA列というのは一時的に仮置きで使用しているということでしょうか?目的は職務の種類(例えばJ,S,M)の抽出でよろしいでしょうか?
  その通りです。ユーザーフォームのリストかコンボを使えば、それでよいですね。

>    
>>     'A列を重複なしでAA列に書き出す。
>>     myR.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AA1"), Unique:=True
>>     'AA列の2行目から終わりまでをmyValに格納
>>     myVal = .Range("AA2", .Range("AA65536").End(xlUp)).Value
>
>だとすると、ユーザーフォームでの職務選択時に職務を取得できるのでそれを利用しようと思います。
>
>●行列の入れ替えですが、行を列にするときに、仕様上見出しが列の真中にも入るため変数を使用せざるを得ないような気がします。
>ponponさんのを改造して下記のようなマクロにしたら、うまく動きました。
>ちなみにsentakuPにはすでにワークシート名が格納されています。

貼り付けた後に行挿入して、見出を入れたらどうですか?
そうすれば、Resizeでデータを取り込めるし、Transposeも使えるし、
ループも楽ではないかと思います。

↓ここのところ

>      With Worksheets("4月")
>
>        myRow4 = Application.Match(c, .Range("C:C"), 0)
>          comp1_4 = .Cells(myRow4, "C").Offset(0, 2).Value
>          comp2_4 = .Cells(myRow4, "C").Offset(0, 3).Value
>          comp3_4 = .Cells(myRow4, "C").Offset(0, 4).Value
>          comp4_4 = .Cells(myRow4, "C").Offset(0, 5).Value
>          comp5_4 = .Cells(myRow4, "C").Offset(0, 6).Value
>          comp6_4 = .Cells(myRow4, "C").Offset(0, 7).Value
>          comp7_4 = .Cells(myRow4, "C").Offset(0, 8).Value
>          comp8_4 = .Cells(myRow4, "C").Offset(0, 9).Value
>          comp9_4 = .Cells(myRow4, "C").Offset(0, 10).Value
>          comp10_4 = .Cells(myRow4, "C").Offset(0, 11).Value
>      End With
>          
>      With Worksheets("点数集計シート")
>            .Range("B13") = comp1_4
>            .Range("B14") = comp2_4
>            .Range("B15") = comp3_4
>            .Range("B16") = comp4_4
>            .Range("B17") = comp5_4
>            .Range("B19") = comp6_4
>            .Range("B20") = comp7_4
>            .Range("B21") = comp8_4
>            .Range("B22") = comp9_4
>            .Range("B23") = comp10_4
>       End With
>      '点数をコピー5月分
>      With Worksheets("5月")
>        myRow5 = Application.Match(c, .Range("C:C"), 0)
>
>          comp1_5 = .Cells(myRow5, "C").Offset(0, 2).Value
>          comp2_5 = .Cells(myRow5, "C").Offset(0, 3).Value
>          comp3_5 = .Cells(myRow5, "C").Offset(0, 4).Value
>          comp4_5 = .Cells(myRow5, "C").Offset(0, 5).Value
>          comp5_5 = .Cells(myRow5, "C").Offset(0, 6).Value
>          comp6_5 = .Cells(myRow5, "C").Offset(0, 7).Value
>          comp7_5 = .Cells(myRow5, "C").Offset(0, 8).Value
>          comp8_5 = .Cells(myRow5, "C").Offset(0, 9).Value
>          comp9_5 = .Cells(myRow5, "C").Offset(0, 10).Value
>          comp10_5 = .Cells(myRow5, "C").Offset(0, 11).Value
>      End With
>          
>      With Worksheets("点数集計シート")
>            .Range("C13") = comp1_5
>            .Range("C14") = comp2_5
>            .Range("C15") = comp3_5
>            .Range("C16") = comp4_5
>            .Range("C17") = comp5_5
>            .Range("C19") = comp6_5
>            .Range("C20") = comp7_5
>            .Range("C21") = comp8_5
>            .Range("C22") = comp9_5
>            .Range("C23") = comp10_5
>       End With
>    
>●結局点数集計シートの各月の入力セル(列)が異なるため、4月シートを基礎として抽出した印刷対象者について、全月の貼り付け作業をを実行していくしかないわけですよね?

私の仕様でも、シートを作成せず、書き込みを工夫すれば何とかなるかも・・・

>つまり対象者ごとにワークシートを作成するわけではないので、各月ごとの繰り返し処理ではなく、ひとりひとり印刷実行までの処理を終わらしていかないといけないので・・・

>●それと平均値の件ですが、ワークシート側に数式を入れてありますのでVBAでの操作は基礎データの入力まで、としました。
>
>以上、ponponさんのソースが非常に参考になりました。
>改めて御礼申し上げます。
>もう少しいろいろと試してみますので、またよろしくお願いします!

お役に立てて何よりです。
私の方も勉強になるのでもう少し考えてみます。

【29096】Re:ワークシート間の検索集計
質問  toki  - 05/9/23(金) 22:03 -

引用なし
パスワード
   ▼ponpon さん:

こんばんは。ご回答ありがとうございます!

>貼り付けた後に行挿入して、見出を入れたらどうですか?
>そうすれば、Resizeでデータを取り込めるし、Transposeも使えるし、
>ループも楽ではないかと思います。
>

点数集計表はすでに「器」として可変データ以外の部分は作成されています。
そうなると、各月の収集データの入力先は、おのずと特定セルになってしまうのですが、その場合も「貼り付けた後に行挿入」というのができるのでしょうか?

実は現段階でファイルの保存がかなり重たくなっておりまして、できる限りモジュールを小さくしたいとは思っています。(もともと私自身にスキルが無いため無駄なコーディングが多いのが原因だとは思うのですが)

ponponさんが言うようにループが楽になればそれに越したことは無いです。

ちなみに、ファイルサイズは731Kです。ファイルサイズと保存速度は関係ありますでしょうか?それともサイズが大きくても作り方によってスピードは上がるのでしょうか?

Saveメソッド、Savecopyasなどを使っていますが、高速保存への道はあるのでしょうか?

モジュールを共通化しコーディングを見直していくしかないのでしょうか?

【29097】Re:ワークシート間の検索集計
発言  ponpon  - 05/9/24(土) 0:23 -

引用なし
パスワード
   こんばんは。

仕様にいろいろ制約があるようで、私にはちょっと難しいようです。
集計表が以下のようだとして

  A   B   C   D   E   F   G   H
1
2 月  4月 5月 6月 7月 8月 9月 6ヶ月平均
3 点数A                    #DIV/0!
4 点数B                    #DIV/0!
5 点数C                    #DIV/0!
6 点数D                    #DIV/0!
7 点数E                    #DIV/0!
8 月  4月 5月 6月 7月 8月 9月 6ヶ月平均
9 点数F                    #DIV/0!
10点数G                    #DIV/0!
11点数H                    #DIV/0!
12点数I                    #DIV/0!
13点数J                    #DIV/0!

職種や氏名や社員番号ををユーザーフォームで指定するなら
以下のようになると思います。試してください。
こちらでは、きちんと書き出されています。

Sub test()
  Dim myR2 As Range, c As Range
  Dim myAry As Variant
  Dim i As Integer, j As Integer
  Dim Ans
 
  Application.ScreenUpdating = False
  '***************************************
  'シート4月から9月までデータの取り出し
  '***************************************
  myAry = Array("4月", "5月", "6月", "7月", "8月", "9月") '全角 シート名も全角で
   
    For i = 0 To UBound(myAry)
    '4月から順に9月のシートまで
    With Worksheets(myAry(i))
      
       'オートフィルターをかける
       .Cells(1, 1).AutoFilter field:=1, Criteria1:="s職"   'ユーザーフォームで指定
      
       '抽出されたB列をmyR2に格納
       Set myR2 = .Range("B2", .Range("B65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
       j = Application.Match("佐藤", .Range("B:B"), 0) 'ユーザーフォームで指定
       If IsError(j) Then
        MsgBox "その人のデータは、ありません": Exit Sub
       Else
        Set c = .Cells(j, 2)
        
        '点数の部分だけをコピーして
        myTen1 = c.Offset(0, 2).Resize(1, 5).Value 'はじめの5つ
        myTen2 = c.Offset(0, 7).Resize(1, 5).Value 'あとの5つ
        'B列(氏名)と同じシートに
        With Worksheets("集計表")
         
         '職種・氏名・社員番号の書き出し
         .Cells(1, 1).Resize(1, 3).Value = c.Offset(0, -1).Resize(1, 3).Value
         
         'コピーしていた点数を行列を入れ替えて貼り付け 5つずつ
         .Cells(3, 8).End(xlToLeft).Offset(0, 1).Resize(5, 1).Value = Application.Transpose(myTen1)
         .Cells(9, 8).End(xlToLeft).Offset(0, 1).Resize(5, 1).Value = Application.Transpose(myTen1)
        End With
       End If
       'オートフィルターの解除
       .AutoFilterMode = False
     
    End With
  
  Next '次の月へ
  
  
  With Application
     .CutCopyMode = False
     .ScreenUpdating = True
  End With
  Ans = MsgBox("印刷しますか?", vbYesNo)
  If Ans = vbYes Then
    MsgBox "印刷します" '実際は印刷処理
  End If
End Sub

【29099】Re:ワークシート間の検索集計
お礼  toki  - 05/9/24(土) 12:46 -

引用なし
パスワード
   ▼ponpon さん:

こんにちは。制約が多くて申し訳ないです。

なるほど、分割して格納すればよいのですね。
やってみます!
後ほど、ご報告させていただきます。
ありがとうございました!

【29104】Re:ワークシート間の検索集計
発言  ponpon  - 05/9/24(土) 21:40 -

引用なし
パスワード
   こんばんは。

コードの見直しをしてみました。
私の力量では、
外側のループを職種・氏名で、内側ループを月別に回すため、
職種と氏名の一覧シートでもあればよいのですが、
それがないので、4月シートにオートフィルターをかけて、
職種別に抽出し、その抽出された一人一人に対して、
4月から9月までマッチした人のデータを集計表に入力するようにしました。

これで、職種を選ぶとその職種全員のデータを印刷することが出来ます。
ユーザーフォームで職種を選び、コマンドボタンなどで実行すれば、
その職種すべての人の印刷が出来ます。
データの貼り付け位置については、そちらで変えてください。
前回こちらが提示した集計表では、全員分抽出されています。
試してください。

Sub test()
  Dim myR2 As Range, c As Range
  Dim myAry As Variant, myTen1 As Variant, myTen2 As Variant
  Dim i As Integer, j As Variant
  Dim Ans
 
  Application.ScreenUpdating = False
  myAry = Array("4月", "5月", "6月", "7月", "8月", "9月") '全角 シート名も全角で
   
  With Worksheets("4月")
   If .AutoFilterMode = True Then .AutoFilterMode = False
   .Cells(1, 1).AutoFilter field:=1, Criteria1:="M職"   'ユーザーフォームで指定
   Set myR2 = .Range("B2", .Range("B65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
   .AutoFilterMode = False
  End With
   
  For Each c In myR2
   For i = 0 To UBound(myAry)
    With Worksheets(myAry(i)) '4月から9月まで順に
     j = Application.Match(c.Value, .Range("B:B"), 0)
     If IsError(j) Then
       MsgBox "その人のデータは、ありません": Exit Sub
     Else
       myTen1 = c.Offset(0, 2).Resize(1, 5).Value 'はじめの5つ
       myTen2 = c.Offset(0, 7).Resize(1, 5).Value 'あとの5つ
       With Worksheets("集計表")
        .Cells(1, 1).Resize(1, 3).Value = c.Offset(0, -1) _
                        .Resize(1, 3).Value
        .Cells(3, 8).End(xlToLeft).Offset(0, 1).Resize(5, 1).Value = _
                     Application.Transpose(myTen1)
        .Cells(9, 8).End(xlToLeft).Offset(0, 1).Resize(5, 1).Value = _
                     Application.Transpose(myTen1)
       End With
      End If
     End With
    Next '次の月へ
        
    With Application
     .CutCopyMode = False
     .ScreenUpdating = True
    End With
       
    Ans = MsgBox("印刷しますか?", vbYesNo)
    If Ans = vbYes Then
      MsgBox "印刷します" '実際は印刷処理
    End If
   Next '次の人へ
End Sub

【29106】Re:ワークシート間の検索集計
お礼  toki  - 05/9/24(土) 23:14 -

引用なし
パスワード
   ▼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 'はじめの5つ
        myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の5つ
        '人事評価シートへ
        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 'はじめの5つ
        myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の5つ
        '人事評価シートへ
        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 'はじめの5つ
        myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の5つ
        '人事評価シートへ
        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 'はじめの5つ
        myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の5つ
        '人事評価シートへ
        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 'はじめの5つ
        myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の5つ
        '人事評価シートへ
        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 'はじめの5つ
        myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の5つ
        '人事評価シートへ
        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

【29108】Re:ワークシート間の検索集計
発言  ponpon  - 05/9/25(日) 5:49 -

引用なし
パスワード
   おはようございます。

>.Cells(3, 8).End(xlToLeft).Offset(0, 1).Resize(5, 1).Value = >Application.Transpose(myTen1)のところなのですが、この場合右側の空白列を順>番に各月のデータで埋めていくループになると認識しております。

>そうするとヒューマンエラーで万が一、データが残ってしまった場合などを考えると、全部ずれていくような気がしております

ならば、前もってデータ範囲をクリアしておけばよいと思います。
ループで回した方が、コードの記述も短くてすむと思います。

>Application.CutCopyMode = False
は、見た目には、コピー元の点点点を消してくれます。
クリップボードの内容をクリアしてくれるものと思われます。
詳しくは、ヘルプ等で・・・・

【29109】Re:ワークシート間の検索集計
お礼  toki  - 05/9/25(日) 8:27 -

引用なし
パスワード
   ▼ponpon さん:

こんにちは。ご回答ありがとうございます。

>ならば、前もってデータ範囲をクリアしておけばよいと思います。
>ループで回した方が、コードの記述も短くてすむと思います。
>

クリアはこんな感じで良いのでしょうか?
初期化してループさせてみます。アドバイスありがとうございました!

'帳票初期化
    With Worksheets("人事評価シート")
      .Cells(13, 1.Resize(5, 1).Value = ""
      .Cells(19, 1).Resize(5, 1).Value = ""
      .Cells(27, 1).Resize(5, 1).Value = ""
      .Cells(33, 1).Resize(5, 1).Value = ""
      .Cells(39, 1).Resize(5, 1).Value = ""
      .Cells(45, 1).Resize(5, 1).Value = ""
      .Cells(13, 2).Resize(5, 1).Value = ""
      .Cells(19, 2).Resize(5, 1).Value = ""
      .Cells(13, 3).Resize(5, 1).Value = ""
      .Cells(19, 3).Resize(5, 1).Value = ""
      .Cells(13, 4).Resize(5, 1).Value = ""
      .Cells(19, 4).Resize(5, 1).Value = ""
      .Cells(13, 6).Resize(5, 1).Value = ""
      .Cells(19, 6).Resize(5, 1).Value = ""
      .Cells(13, 7).Resize(5, 1).Value = ""
      .Cells(19, 7).Resize(5, 1).Value = ""
      .Cells(13, 8).Resize(5, 1).Value = ""
      .Cells(19, 8).Resize(5, 1).Value = ""
      .Cells(27, 2).Resize(5, 1).Value = ""
      .Cells(33, 2).Resize(5, 1).Value = ""
      .Cells(39, 2).Resize(5, 1).Value = ""
      .Cells(45, 2).Resize(5, 1).Value = ""
    End With

【29122】Re:ワークシート間の検索集計
発言  ponpon  - 05/9/25(日) 16:50 -

引用なし
パスワード
   こんにちは。

With Worksheets("人事評価シート")
  .Range("A19:H23,A27:B31,A33:B37,A39:B43,A45:B49").ClearContents
End With

かな?

【29126】Re:ワークシート間の検索集計
質問  toki  - 05/9/25(日) 19:45 -

引用なし
パスワード
   ▼ponpon さん:
こんにちは。
なるほど簡単ですね。ありがとうございます。

ところで、もうひとつ質問があります。

全社員、全月の得点部分だけを一括クリアする場合、下記のようなコードではまったくダメでしょうか?
というかオブジェクトエラーになってしまいます。

ちなみに得点データ領域は、7行目、4列目以降です。
    'A列を上から順に
    For Each daTa In myDR
      daTagyo = daTa.Offset(0, 3).Resize(1, 10).Value
      daTagyo.Delete
    Next
の部分がダメらしいのですが・・・

  1    2    3     4
  職務 氏名 社員番号 得点・・・・・
7 J              ●
8 J              ●
9 J              ●





Private Sub データクリアボタン_Click()
  
  Dim myDR As Range
  Dim daTa As Variant
  Dim daTagyo As Variant
  Dim ans As Integer
  Dim i As Integer
  
  Application.DisplayAlerts = False
  ans = MsgBox("全社員の得点データを一括削除します。本当に削除しますか?", vbYesNo + vbExclamation, "オールクリア")
  
  Select Case ans
    Case vbYes
    MsgBox "全社員の得点データを削除します。", vbInformation, "オールクリア"
       
  '****************************************
  '各月シートから得点データ領域を削除
  '****************************************
  For i = 1 To 12
  With Worksheets(i & "月")
    '抽出されたA列をmyDRに格納
    Set myDR = .Range("A7", .Range("A65536").End(xlUp)).SpecialCells(xlCellTypeVisible)

    'A列を上から順に
    For Each daTa In myDR
      daTagyo = daTa.Offset(0, 3).Resize(1, 10).Value
      daTagyo.Delete
    Next
  End With
  Next
    
    Case vbNo
  
  End Select
  Application.DisplayAlerts = True
End Sub

【29128】Re:ワークシート間の検索集計
発言  ponpon  - 05/9/25(日) 21:41 -

引用なし
パスワード
   こんばんは。
>    'A列を上から順に
>    For Each daTa In myDR
>      daTagyo = daTa.Offset(0, 3).Resize(1, 10).Value
>      daTagyo.Delete
>    Next

Deleteは、オブジェクトを削除するときに使います。
セル自体を削除するときには、Delete
セルの値を削除するときは、ClearContents
セルの書式を削除するときは、ClearFormats
書式を含むセルの値を削除したときには、Clear

Set myDR = .Range("A7", .Range("A65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
 myDR.ClearContents

これでは、抽出されたところだけですが・・・
すべてをクリアしたいなら、
一度、クリアしたい範囲を選択して、マクロの記録をとられたらいかがでしょう?

【29188】Re:ワークシート間の検索集計
質問  toki  - 05/9/27(火) 12:01 -

引用なし
パスワード
   ▼ponpon さん:
こんにちは。tokiです。

ご指摘の通りマクロ記録でやってみましたが、マクロ記録ではやはり、セル範囲が特定されてしまうので、運用に耐えないようです。

見出し 6行目まで
社員データ 7行目以降

現在までご説明したように仕様としては7行以降の社員データ行は追加や削除によって可変のため、マクロ記録ですと難しいです。

そこで、次のようなマクロを作成しましたが・・・

Private Sub データクリアボタン_Click()
  
  Dim myDR As Range
  Dim daTa As Variant
  Dim daTagyo As Variant
  Dim ans As Integer
  
  Application.DisplayAlerts = False
  ans = MsgBox("全社員の得点データを一括削除します。本当に削除しますか?", vbYesNo + vbExclamation, "オールクリア")
  
  Select Case ans
    Case vbYes
    MsgBox "全社員の得点データを削除します。", vbInformation, "オールクリア"
       
  '****************************************
  '各月シートから得点データ領域を削除
  '****************************************
  For i = 1 To 12
  With Worksheets(i & "月")
    
    ’データ領域は7行目以降の各行D列〜N列。この範囲を指定
    Set myDR = .Range("D7", .Range("N65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
     myDR.ClearContents
    End With
  Next
    Case vbNo
  
  End Select
  Application.DisplayAlerts = True
End Sub

実行すると一見うまく行くのですが、全データを削除した後に、再度削除ボタンを押すとエラーがでます。
.Range("D7", .Range("N65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
にしているため、7行目以降のN列のデータが無い状態では、.Range("N65536").End(xlUp)が6行目の見出し部分を示すことになり
エラーとなってしまうのでしょうか?

やはり、各行を指定して該当行にクリアの繰り返し処理を入れていく方法がよいのかな、と思っています。
そこで方法として、A列の職務から可視データすべてを抽出し、順番にデータ領域(4列目〜14列目)を削除する、という繰り返し処理ができないでしょうか?
A列の全ての職務は"*職"で抽出できます。

例えば

Private Sub データクリアボタン_Click()
  
  Dim myDR As Range
  Dim daTa As Variant
  Dim daTagyo As Variant
  Dim ans As Integer
  Dim i As Integer
  Dim k As Variant
  
  Application.DisplayAlerts = False
  ans = MsgBox("全社員の得点データを一括削除します。本当に削除しますか?", vbYesNo + vbExclamation, "オールクリア")
  
  Select Case ans
    Case vbYes
    MsgBox "全社員の得点データを削除します。", vbInformation, "オールクリア"
       
  '****************************************
  '各月シートから得点データ領域を削除
  '****************************************
  For i = 1 To 12
    With Worksheets(i & "月")
    
    k = Application.Match("*職", .Range("A:A"), 0)
      If Not IsError(k) Then
      .Cells(k, 4).ClearContents
      .Cells(k, 5).ClearContents
      .Cells(k, 6).ClearContents
      .Cells(k, 7).ClearContents
      .Cells(k, 8).ClearContents
      .Cells(k, 9).ClearContents
      .Cells(k, 10).ClearContents
      .Cells(k, 11).ClearContents
      .Cells(k, 12).ClearContents
      .Cells(k, 13).ClearContents
      .Cells(k, 14).ClearContents
      Else
      Exit Sub
      End If
    
    End With
  Next
    Case vbNo
  
  End Select
  Application.DisplayAlerts = True
End Sub

こういう感じにすると、各シートの1行目だけは削除できます。
これを、A列において"*職"が存在している限り、ループさせる、というマクロにするためにはどのように改造すればよいでしょうか?
ご指導お願いいたします。

【29199】Re:ワークシート間の検索集計
お礼  toki  - 05/9/27(火) 14:21 -

引用なし
パスワード
   ▼ponpon さん:
ponponさんこんにちは。

結局、このやり方がもっともシンプルでした。
範囲を .Range("D7", .Range("N65536")).SpecialCells(xlCellTypeVisible)
にすることで、エラーも出なくなりました。

この方法でいきたいと思います。
ありがとうございました。

Private Sub データクリアボタン_Click()
  
  Dim myDR As Range
  Dim daTa As Variant
  Dim daTagyo As Variant
  Dim ans As Integer
 
  Application.DisplayAlerts = False
  ans = MsgBox("全社員の得点データを一括削除します。本当に削除しますか?", vbYesNo + vbExclamation, "オールクリア")
 
  Select Case ans
    Case vbYes
    MsgBox "全社員の得点データを削除します。", vbInformation, "オールクリア"
    
  '****************************************
  '各月シートから得点データ領域を削除
  '****************************************
  For i = 1 To 12
  With Worksheets(i & "月")
  
    'データ領域は7行目以降の各行D列〜N列。この範囲を指定
    Set myDR = .Range("D7", .Range("N65536")).SpecialCells(xlCellTypeVisible)
     myDR.ClearContents
    End With
  Next
  
    Case vbNo
 
  End Select
  Application.DisplayAlerts = True
End Sub

【29437】Re:ワークシート間の検索集計
質問  toki  - 05/10/4(火) 23:08 -

引用なし
パスワード
   ▼ponpon さん:
こんにちは。どうも行き詰まってしまいました。
教えてください。

実行中、データ型エラーがおきます。

「4月点数コピーペースト」のところです。

どうしてでしょうか?

基本仕様は、ユーザーフォームで指定した職務を、「4月」ワークシートのA列より抽出し、その行に付随するデータを
フォーマット変更して人事評価シートにペーストする作業工程です。
4月ワークシートは
A列 職務
D列〜N列が得点です。

お気づきの点がありましたらご教示よろしくお願いします。


Private Sub 職務別印刷上期実行ボタン_Click()

  Dim erCh As Variant
  Dim comP1 As Variant
  Dim gyo As Variant
  Dim ten As Range
  Dim c As Range
  Dim myten1 As Variant, myten2 As Variant
  Dim mycomiT As Variant
  
  
  Application.ScreenUpdating = False
  
  'ユーザーフォームの表示テキストから職務名を変数に代入
  sentakuI = Replace(sentakuP, "Level", "") ’←sentakuPというのは「職務+Level」で構成された変数のため、「職務」だけを抽出しています。
  
  
  '社員登録がされている職務かどうかのチェック
  With Worksheets("4月")
  erCh = Application.Match(sentakuI, .Range("A:A"), 0)
  End With
    
  If Me.職務別印刷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
 

      '****************************************
      '4月点数コピーペースト
      '****************************************
      '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 'はじめの5つ
        myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の5つ
        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

    Next


  End With
        
    
  End If
  
  Application.ScreenUpdating = True
End Sub

【29448】Re:ワークシート間の検索集計
発言  Jaka  - 05/10/5(水) 13:16 -

引用なし
パスワード
   Set myR = .Range("C7", "C65536").SpecialCells(xlCellTypeVisible)
これで抽出セルをセットしているのですから、この後のMatch関数による検索は2度手間になります。
myRをループして回せば良いです。
あまし良く見てないので、違ってたらすみません。

  '点数集計
  '****************************************
  '職務によるオートフィルター絞込み
  '****************************************
  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
      myten1 = c.Offset(0, 0).Resize(1, 5).Value 'はじめの5つ
      myten2 = c.Offset(0, 5).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

      'オートフィルターの解除
      Worksheets("4月").AutoFilterMode = False
      'プリントアウト
      Worksheets("人事評価シート").PrintOut
      DoEvents
    Next
  End With

【29454】Re:ワークシート間の検索集計
発言  ponpon  - 05/10/5(水) 18:34 -

引用なし
パスワード
   ▼toki さん、Jakaさん
 こんばんは。

>
>
>Private Sub 職務別印刷上期実行ボタン_Click()
>
>  Dim erCh As Variant
>  Dim comP1 As Variant
>  Dim gyo As Variant
>  Dim ten As Range
>  Dim c As Range
>  Dim myten1 As Variant, myten2 As Variant
>  Dim mycomiT As Variant
>  
>  
>  Application.ScreenUpdating = False
>  
>  'ユーザーフォームの表示テキストから職務名を変数に代入
>  sentakuI = Replace(sentakuP, "Level", "") ’←sentakuPというのは「職務+Level」で構成された変数のため、「職務」だけを抽出しています。
>  
>  
>  '社員登録がされている職務かどうかのチェック
>  With Worksheets("4月")
>  erCh = Application.Match(sentakuI, .Range("A:A"), 0)
>  End With
  
   sentakuPは、TextBox1.Value ですか?
   それなら、ここですでにsentakuIによる検索があっていることになります。
   つまり、職務を下でオートフィルターで抽出しているので、登録しているかどうかの
   二重チェックの意味ですか?
   
>    
>  If Me.職務別印刷TextBox1.Value = "" Then
>    MsgBox "いずれかの職務を選択してください。", vbExclamation, "職務選択": Exit Sub

   したがって、これは、検索前に行わないといけないと思います。ここが空だと
   sentakuIによる検索ができないと思います。

>  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
> 
>
>      '****************************************
>      '4月点数コピーペースト
>      '****************************************
>      '4月
>      With Worksheets("4月")
>        gyo = Application.Match(c, .Range("C:C"), 0)
                        ↑
                       c.value??

    でも、Jakaさんが言っているように、   
   Set myR = .Range("C7", "C65536").SpecialCells(xlCellTypeVisible)
    この段階で、sentakuIによる抽出は、終わっているので、
   myRを順番に転記していけばよいのでは・・・・
   For Each C in myR
    myten1 = C.Offset(0, 0).Resize(1, 5).Value 'はじめの5つ
    myten2 = C.Offset(0, 5).Resize(1, 5).Value '次の5つ
    mycomiT = C.Offset(0, -1).Value 'コミット取り出し
   
    ただ、C.Valueというのが特定の社員番号なら話は別ですが・・・
    このままでは、
   For Each C in myRのC と
   gyo = Application.Match(c, .Range("C:C"), 0)の
        C.Valueは同じになります。
   それなら、gyo = Application.Match(c, .Range("C:C"), 0)は、
   意味ないと思います。


>        Set ten = .Cells(gyo, 5) '←←←ここでエラー反転しています。型が違うとのこと。
>        '点数のコピー
>        myten1 = ten.Offset(0, 0).Resize(1, 5).Value 'はじめの5つ
>        myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の5つ
>        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
>
>    Next
>
>
>  End With
>        
>    
>  End If
>  
>  Application.ScreenUpdating = True
>End Sub

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

引用なし
パスワード
   ▼Jaka さん:
ご回答ありがとうございます。
Jakaさんのソースを貼り付けて実行してみましたが、無限ループに入ってしまいます。

ちなみに4月シートの状況ですが、J職社員番号8番の人間が1件あります。

そこでJ職を指定して、印刷をかけました。本来だと、J職でオートフィルターがかけられてC列の社員番号から8番だけを拾って
印刷実行し、終了するはずなのですが、無限印刷に入ります。

※なお下記変数のうちsentakuI には、J職が格納され、erChには社員番号の”8番”が格納されていることをウォッチ式で確認してます。
従って点数集計以降のループの問題だと思うのですがいかがでしょうか?

Private Sub 職務別印刷上期実行ボタン_Click()

  Dim erCh As Variant
  Dim mycomPT As Variant
  Dim hvten As Variant
  Dim myten1 As Variant, myten2 As Variant
  Dim mycomiT As Variant
  Dim myR As Range
  
  
  Application.ScreenUpdating = False
  
  sentakuI = Replace(sentakuP, "Level", "")
  
  
  '社員登録がされている職務かどうかのチェック
  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
      myten1 = c.Offset(0, 0).Resize(1, 5).Value 'はじめの5つ
      myten2 = c.Offset(0, 5).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

      'オートフィルターの解除
      Worksheets("4月").AutoFilterMode = False
      'プリントアウト
      Worksheets("人事評価シート").PrintOut
      DoEvents
    Next
  End With

    
  End If
  
  Application.ScreenUpdating = True
End Sub

【29462】Re:ワークシート間の検索集計
発言  toki  - 05/10/5(水) 22:12 -

引用なし
パスワード
   >※なお下記変数のうちsentakuI には、J職が格納され、erChには社員番号の”8番”が格納されていることをウォッチ式で確認してます。
>従って点数集計以降のループの問題だと思うのですがいかがでしょうか?

●すいません。誤記です。erChには行番号の"7"が格納されています。

【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

【29467】Re:ワークシート間の検索集計
発言  ponpon  - 05/10/5(水) 22:55 -

引用なし
パスワード
   こんばんは。

>  sentakuI = Replace(sentakuP, "Level", "")
>  sentakuV = Replace(sentakuP, "Level", "") + "value

この変数は、ユーザーフォームからですか?

まずは、F8キーを使って1ステップずつ確かめることをお勧めします。
VBEの画面からF8を押して、Excelの画面を確認、VBEに戻り、F8を押す。
Excelの画面を確認・・・・・
自分の考えているように、動作や画面が進んでいるかを確かめたらいかがでしょうか?
すると、
どこで無限ループに入っているかが分かると思います。
もちろん、印刷の部分は、プレビューに変えてください。
また、いろんな所に、SelectやMsgboxを入れ、値や選択範囲を確認しています。

私は、上記のようなことをして、自分のコードのバグを探して、修正しています。

【29526】Re:ワークシート間の検索集計
お礼  toki  - 05/10/6(木) 21:57 -

引用なし
パスワード
   ▼ponpon さん:
アドバイスありがとうございます。ひとつずつ追っかけてみたところ、やはりFor文が無限ループになっていました。
myRの要素がなくなったらループは終わるかと思ったのですが、空白のままループしてしまうようです。
そこで、
If c.Value = "" Then
  Exit For
を入れたところ、うまく抜けられました。

ところで、点数のコピペのところなのですが、変数cを起点に、offsetをかけると、4月単月はよいのですが、5月以降も変数cを起点にすると
4月のデータが張り付いてしまうことがわかりました。
変数cをオブジェクト(セル)として考えていたのですが、あくまでも社員番号の値しか格納できていないような感じでした。
そこで、各月のC列から社員番号の行を拾いだして起点のセルを変数tenにSetしてResizeしたところうまくいきました。

私はどうもコレクションやオブジェクトの捉え方が曖昧なようです・・・

というわけで結果としてはデバッグを細かくやったことで解決?したようです。
もっとうまいやり方があるかもしれませんが、とりあえずアドバイスのおかげで急場はしのげました。

どうもありがとうございました!

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 'はじめの5つ
        myten2 = ten.Offset(0, 5).Resize(1, 5).Value '次の5つ
        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

【29529】Re:ワークシート間の検索集計
発言  ponpon  - 05/10/6(木) 23:34 -

引用なし
パスワード
   ▼toki さん:
>▼ponpon さん:
>アドバイスありがとうございます。ひとつずつ追っかけてみたところ、やはりFor文が無限ループになっていました。
>myRの要素がなくなったらループは終わるかと思ったのですが、空白のままループしてしまうようです。
>そこで、
> If c.Value = "" Then
>  Exit For
>を入れたところ、うまく抜けられました。

Set myR = .Range("C7", "C65536").SpecialCells(xlCellTypeVisible)
       ↓
Set myR = .Range("C7", .Range("C65536").End(xlUp).SpecialCells(xlCellTypeVisible)

としないとC65536までいくようです。(無限ではありませんが確認しました)
 myR.Selectと入れてみるとわかったと思います。

>ところで、点数のコピペのところなのですが、変数cを起点に、offsetをかけると、4月単月はよいのですが、5月以降も変数cを起点にすると
>4月のデータが張り付いてしまうことがわかりました。


>そこで、各月のC列から社員番号の行を拾いだして起点のセルを変数tenにSetしてResizeしたところうまくいきました。
 ↑
これをやっているつもりでしたが・・・・
仕様の全景が見えているわけではないので何ともいえませんが、
With Worksheets("5月")
  Set myR = .Range("C7", .Range("C65536").End(xlUp).SpecialCells(xlCellTypeVisible)
 For Each c In myR
・・・・・・・・・
・・・・・・・・・
 Next

End With
となっていれば、そんなことにはならないと思いますし、
>変数cをオブジェクト(セル)として考えていたのですが
でよいと思います。
.Rangeの.の前は、何の省略なのか。親は何なのか?
With節の使い方に間違いがあるのかもしれません。

私がわかるのは、これだけです。
がんばってください。

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