Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2205 / 76735

←次へ　｜　前へ→


	【80174】部課ごとに各項目で集計したい

名木 - 18/10/6(土) 14:55 -


	引用なし

	パスワード

人事シートをもとに、社員部課別で指定した項目の集計をしたいと
思います。
シンプルで分かりやすいマクロを教えていただけないでしょうか？
結果を示すシートは[集計シート]とします。

Option Explicit

Sub ColCopy()
　　Dim xlBook As Workbook
　　Dim xlSheetOrg As Worksheet
　　Dim xlSheetSel As Worksheet
　　Dim xlSheetDst As Worksheet
　　Dim strDstSheetName As String
　　Dim rngLastRow As Range
　　Dim vntIndex As Variant
　　Dim rngIndexs As Range
　　Dim rngHeader As Range
　　Dim lngColSrc As Long
　　Dim lngColDst As Long
　　Dim rngTargetCol As Range
　　
　　
　　Set xlBook = ThisWorkbook
　　
　　With xlBook
　　　　Set xlSheetSel = .Worksheets("指定")
　　　　Set xlSheetOrg = .Worksheets("人事")
　　End With
　　
　　' コピー先シート名取得
　　strDstSheetName = xlSheetSel.Range("A2").Value
　　
　　' コピー先シートを初期化（なければ生成）
　　On Error GoTo ERR_DST_SHEET
　　Set xlSheetDst = xlBook.Worksheets(strDstSheetName)
　　With xlSheetDst
　　　　.Cells.Clear
　　End With
　　On Error GoTo 0
　　
　　
　　' 項目名を読み取り
　　With xlSheetSel
　　　　Set rngLastRow = .Cells(.Rows.Count, 1).End(xlUp)
　　　　Set rngIndexs = .Range(.Cells(21, 1), rngLastRow)
　　　　Set rngLastRow = Nothing
　　End With
　　
　　' 見出し行の取り込み
　　Set rngHeader = xlSheetOrg.Rows(1)
　　
　　' 該当列のコピー
　　Application.ScreenUpdating = False
　　With xlSheetDst
　　　　lngColDst = 0
　　　　For Each vntIndex In rngIndexs
　　　　　　lngColDst = lngColDst + 1
　　　　　　Set rngTargetCol = rngHeader.Find(CStr(vntIndex))
　　　　　　lngColSrc = rngTargetCol.Column
　　　　　　rngTargetCol.EntireColumn.Copy .Cells(1, lngColDst)
　　　　　　Set rngTargetCol = Nothing
　　　　Next vntIndex
　　　　Set rngIndexs = Nothing
　　End With
　　Application.ScreenUpdating = True
　　
　　GoTo PROC_END
　　
ERR_DST_SHEET:
　　Set xlSheetDst = Sheets.Add(, Sheets("集計"))
　　xlSheetDst.Name = strDstSheetName
　　Resume Next
　　
PROC_END:
　　Set rngHeader = Nothing
　　Set xlSheetDst = Nothing
　　Set xlSheetOrg = Nothing
　　Set xlSheetSel = Nothing
　　Set xlBook = Nothing

End Sub

[人事シート]
　A　　　　　　B　　　　　　　　　C　　　　　　　D　　　　　　　E　　　　　　　　F　　　　G　　　　
1社員氏名　社員部課　　　社員体系平日出勤休日出勤出勤時間残業手当Ａ
2京都　太郎パートフロアーパート　　　　　　　　　　　　　　　　　　　　
3山田　山太　生産　　　　　社員　　　　　　　　　　　　　　　　　　　　
4木本　樹　フロアー　　　　　　社員　　　　　　　　　　　　　　　　　　　　

[指定シート]
　　　　A列
1　　　　集計先
2　　　　集計
3　　　　
4　　　　項目名
5　　　　社員氏名
6　　　　社員部課
7　　　　社員体系
8　　　　支給合計
9　　　　所得税
10　　　　課税通勤手当
11　　　　非課税通勤手当
12　　　　時間外Ａ金額
13　　　　時間外Ｂ金額
14　　　　時間外Ｃ金額
15　　　　時間外Ｄ金額
16　　　　健康保険料(一般)
17　　　　健康保険料(介護)
18　　　　厚生年金保険料
19　　　　雇用保険料
20　　　　住民税
21　　　　控除項目４
22　　　　控除項目５

0 hits

▼

【80174】部課ごとに各項目で集計したい 名木 18/10/6(土) 14:55