|
人事シートをもとに、社員部課別で指定した項目の集計をしたいと
思います。
シンプルで分かりやすいマクロを教えていただけないでしょうか?
結果を示すシートは[集計シート]とします。
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社員氏名 社員部課 社員体系 平日出勤 休日出勤 出勤時間 残業手当A
2京都 太郎 パートフロアー パート
3山田 山太 生産 社員
4木本 樹 フロアー 社員
[指定シート]
A列
1 集計先
2 集計
3
4 項目名
5 社員氏名
6 社員部課
7 社員体系
8 支給合計
9 所得税
10 課税通勤手当
11 非課税通勤手当
12 時間外A金額
13 時間外B金額
14 時間外C金額
15 時間外D金額
16 健康保険料(一般)
17 健康保険料(介護)
18 厚生年金保険料
19 雇用保険料
20 住民税
21 控除項目4
22 控除項目5
|
|