Excel VBA質問箱 IV

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

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


52473 / 76732 ←次へ | 前へ→

【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
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 発言

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