Excel VBA質問箱 IV

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

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


52539 / 76736 ←次へ | 前へ→

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

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