データを表に変換して集計

前提・実現したいこと

勤怠データを表に変換して、集計を行います。

色々調べ、試行錯誤して作成しましたが1）～10）をまとめてコードにする能力がありませんので、それぞれのコードをCallでつないで作成しております。

1）シート執務日報のデータをシート結果にコピーする
2）シート結果のH列（場所）を頭文字（1字）のみにする
3）シート結果のJ列（氏名）を苗字のみにする
4）シート結果のJ列の人をシート仕様書のC4～（下に）に重複しないリストを作成する
5）シート表にシート結果を基にD列（日付）、E列（大項目）、H列（場所）、J列（氏名）で集計した表を作成する
6）シート仕様書のC4～をリストで並べ替える**（手動）**
7）6）を基にシート表を並べ替える
8）シート仕様書のJ3～J8をシート表の最終行より1行空けたA列に貼り付ける（未了）
9）シート表に8）の場所毎に人毎に集計する（未完成）
10）シート表の列幅を揃える（未了）

**※**シート執務日報のK列は小数点があります

問題点

①　4）にエラーが出ます。
先月まではエラーはありませんでした。
何が原因か分かりません。

実行時エラー1004
アプリケーション定義またはオブジェクト定義のエラーです。

.Add Type:=xlValidateList, _
                AlertStyle:=xlValidAlertStop, _
                Operator:=xlBetween, _
                Formula1:="=名前リスト"

②　処理時間が長いです。
可能であれば、もう少し短くしたいです。

③　8）と10）は未了です

④　9）は未完成です

その他、コードの書き方でおかしい箇所等ありましたらご指導いただけないでしょうか？
よろしくお願いいたします。

該当のソースコード

1）

Option Explicit
 Sub 結果へコピー()
 
    Dim myFrmSht As Worksheet
    Dim myToSht As Worksheet
    Dim myCell As Rang

    Set myFrmSht = Worksheets("執務日報")
    Set myToSht = Worksheets("結果")

    For Each myCell In myFrmSht.Range("A1").CurrentRegion
        If Len(myCell.Value) = 0 Then
            myCell.Value = "他"
        End If
    Next

    myToSht.Cells.Clear

    myFrmSht.Range("A1").CurrentRegion.Copy myToSht.Range("A1")
    myToSht.Range("A1").CurrentRegion.EntireColumn.AutoFit

    myToSht.Range("A1").CurrentRegion.RemoveDuplicates Columns:=Array(4, 5, 8, 10), _
        Header:=xlNo

     With myToSht.Range("A1").CurrentRegion
        With .Offset(1, 10).Resize(.Rows.Count - 1, 1)
            .FormulaR1C1 = _
            "=SUMIFS(執務日報!C,執務日報!C[-7],RC[-7],執務日報!C[-6],RC[-6],執務日報!C[-3],RC[-3],執務日報!C[-1],RC[-1])"
            .Value = .Value
        End With
    End With

 End Sub

2）

Sub 苗字のみに変更()

    Dim i As Integer
    Dim v
    Dim s
    Dim a
    Dim r  As Range
    
    Set a = Worksheets("結果")
    
    For i = 2 To a.Cells(Rows.Count, "J").End(xlUp).Row
    
    Set r = a.Cells(i, "J")
    
    s = r.Value
    v = Split(s, "　")
    
    r.Offset(0, 0).Value = v(0)
    
     Next i
    
 End Sub

3）

Option Explicit
Sub 場所を略称に変更()

        Dim i As Integer
        Dim a

       Set a = Worksheets("結果")

        For i = 2 To a.Cells(Rows.Count, "J").End(xlUp).Row
            a.Cells(i, "H").Value = Left(a.Cells(i, "H").Value, 1)
        Next i

    End Sub

4）

Sub 名前リストを作成()

Dim a As Worksheet, b As Worksheet
 
    Set a = Worksheets("結果")
    Set b = Worksheets("仕様書")

    With a
        With .Range(.Range("J1"), .Cells(.Rows.Count, "J").End(xlUp))
            b.Range("P1").Resize(.Rows.Count, 1).Value = .Value
        End With
    End With
     
    With b
        With .Range(.Range("P1"), .Cells(.Rows.Count, "P").End(xlUp))
            .RemoveDuplicates Columns:=1, Header:=xlNo
        End With
    End With
      
    With b.Columns("C:C")
        With .Validation
            .Delete
            .Add Type:=xlValidateList, _
                AlertStyle:=xlValidAlertStop, _
                Operator:=xlBetween, _
                Formula1:="=名前リスト"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .IMEMode = xlIMEModeNoControl
            .ShowInput = True
            .ShowError = True
        End With
    End With
End Sub

5）

Public Sub 結果を表へ出力()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim Cnt As Long
    Dim lr As Long
    Dim Aary() As Variant
    Dim Mary() As Variant
    Dim Dm As Object
    Dim Mm As Object
    Dim Var As Variant
    Dim Base As Variant
    
    If ExistsWorkSheet("表") = True Then
        Application.DisplayAlerts = False
        Worksheets("表").Delete
        Application.DisplayAlerts = True
    End If

    Set Dm = CreateObject("Scripting.Dictionary")
    Set Mm = CreateObject("Scripting.Dictionary")
    With Worksheets("結果")
        lr = .Cells(.Rows.Count, 4).End(xlUp).Row
        Base = Intersect(.Range("D:K"), .Range(.Rows(2), .Rows(lr)))
        .Copy after:=Worksheets(Worksheets.Count)
    End With
    Worksheets(Worksheets.Count).Name = "表"
    For i = 1 To UBound(Base, 1)
        Dm(Base(i, 1)) = Empty
        Mm(Base(i, 7)) = Empty
    Next
    Mary = Mm.keys
    ReDim Aary(1 To Dm.Count, 1 To Mm.Count + 1)
    For i = 1 To UBound(Base, 1)
        For Each Var In Dm
            Cnt = Cnt + 1
            If Var = Base(i, 1) Then
                Aary(Cnt, 1) = Var
                For k = 0 To UBound(Mary)
                    If Base(i, 7) = Mary(k) Then
                        Aary(Cnt, k + 2) = Aary(Cnt, k + 2) & Base(i, 5) & Base(i, 8) & " "
                    End If
                Next
            End If
        Next
        Cnt = 0
    Next
    Worksheets("?\").Activate
    With ActiveSheet
        .UsedRange.Clear
        .Cells(1, 2).Resize(, UBound(Mary) + 1) = Mary
        .Cells(2, 1).Resize(UBound(Aary, 1), UBound(Aary, 2)) = Aary
        .UsedRange.EntireColumn.AutoFit
        .UsedRange.Borders.LineStyle = xlContinuous
        .Range("A:A").SpecialCells(2).NumberFormatLocal = "yyyy/mm/dd"
    End With
    Set Dm = Nothing
    Set Mm = Nothing
    Erase Base, Aary, Mary
End Sub

Public Function ExistsWorkSheet(ByVal sheetName As String) As Boolean
    Dim ws As Worksheet
    ExistsWorkSheet = False
    For Each ws In Worksheets
        If UCase(ws.Name) = UCase(sheetName) Then
            ExistsWorkSheet = True
            Exit Function
        End If
    Next ws
End Function

7）

Public Sub 仕様書の名前順に並べ替え()
    Dim ws As Worksheet
    Dim ms As Worksheet
    Dim mscp As Worksheet
    Dim dicM As Object  
    Dim dicW As Object  
    Dim maxrowM As Long
    Dim maxrowW As Long
    Dim maxcolW As Long
    Dim wrow As Long
    Dim wcol As Long
    Dim set_col As Long
    Dim set_row As Long
    Dim key As Variant
    Dim Warr As Variant
    Set ws = Worksheets("表")
    Set ms = Worksheets("仕様書")
    Set dicM = CreateObject("Scripting.Dictionary")
    Set dicW = CreateObject("Scripting.Dictionary")
    maxrowM = ms.Cells(Rows.Count, "C").End(xlUp).Row
    maxrowW = ws.Cells(Rows.Count, "A").End(xlUp).Row 
    maxcolW = ws.Cells(1, Columns.Count).End(xlToLeft).Column  

    If maxrowM < 4 Then Exit Sub
    If maxrowW < 2 Then Exit Sub
    If maxcolW < 2 Then Exit Sub
    
    For wrow = 4 To maxrowM
        key = ms.Cells(wrow, "C").Value
        dicM(key) = True
    Next
   
    For wcol = 2 To maxcolW
        key = ws.Cells(1, wcol).Value
        If dicM.exists(key) = False Then
            MsgBox ("仕様書" & key & "なし")
            Exit Sub
        End If
        dicW(key) = wcol
    Next
    
    Warr = ws.Range(ws.Cells(1, 1), ws.Cells(maxrowW, maxcolW)).Value
   
    ms.Copy after:=Worksheets(Worksheets.Count)
    Set mscp = Worksheets(Worksheets.Count)
    mscp.Range("B4:" & "C" & maxrowM).Sort key1:=Range("B4"), order1:=xlAscending
    set_col = 2
    For wrow = 4 To maxrowM
        key = mscp.Cells(wrow, "C").Value
        If dicW.exists(key) = True Then
            For set_row = 1 To maxrowW
                ws.Cells(set_row, set_col).Value = Warr(set_row, dicW(key))
            Next
            set_col = set_col + 1
        End If
    Next
    
    Application.DisplayAlerts = False
    mscp.Delete
    Application.DisplayAlerts = True
    MsgBox ("並べ替え完了")
End Sub

9）

Sub 表を集計する()
    Dim c As Range
    
    For Each c In Range("A:A").SpecialCells(2)
        If c.Value = "本社" Or c.Value = "事務所" Or c.Value = "子会社" Or c.Value = "支店・営業所" Or c.Value = "その他" Or c.Value = "合計" Then c.Offset(, 1).Resize(, 2).ClearContents
    Next c
    For Each c In Range("B:Q").SpecialCells(2)
        Call subx(c.Value, c.Column)
    Next c
End Sub

Function subx(arg1, arg2)
    Dim i As Long, rw As Long
    For i = 1 To Len(arg1)

        If Mid(arg1, i, 1) = "本" Or Mid(arg1, i, 1) = "事" Or Mid(arg1, i, 1) = "子" Or Mid(arg1, i, 1) = "支" Or Mid(arg1, i, 1) = "他" Then
        rw = Range("A:A").Find(Mid(arg1, i, 1), , , xlPart).Row
        Cells(rw, arg2).Value = Val(Cells(rw, arg2).Value) + Val(Mid(arg1, i + 1))
        rw = Range("A:A").Find("???v", , , xlWhole).Row
        Cells(rw, arg2).Value = Val(Cells(rw, arg2).Value) + Val(Mid(arg1, i + 1))
        End If

    Next i
End Function

様式

◆執務日報

◆結果

◆表

ピポッドテーブル

行動規範の内容に同意します

回答1件

ベストアンサー

例えば、
自ブック（マクロを仕込むブック）に、
日報
集計表
作業用
の3つのシートがあるとします。
そして日報シートに、

  日付        場所          氏名        執務時間  
                                                  
    2020.7.1  事務所        織田　信長         7  
                                                  
    2020.7.5  事務所        明智　光秀       2.5  
                                                  
    2020.7.9  本社          織田　信長       3.5  
                                                  
   2020.7.13  本社          千　利休           1  
                                                  
   2020.7.17  本社          徳川　家康         5  
                                                  
   2020.7.21  子会社        武田　信玄         7  
                                                  
   2020.7.25  支店・営業所  織田　信長       2.5  
                                                  
   2020.7.29  事務所        明智　光秀       3.5  
                                                  
    2020.8.2  事務所        織田　信長         1  
                                                  
    2020.8.6  事務所        千　利休           5  
                                                  
   2020.8.10  本社          徳川　家康         7  
                                                  
   2020.8.14  本社          武田　信玄       2.5  
                                                  
   2020.8.18  本社          織田　信長       3.5  
                                                  
   2020.8.22  子会社        明智　光秀         1  
                                                  
   2020.8.26  支店・営業所  織田　信長         5  
                                                  
   2020.8.30  本社          千　利休           7  
                                                  
    2020.9.3  子会社        徳川　家康       2.5  
                                                  
    2020.9.7  支店・営業所  武田　信玄       3.5

というようなデータがあるとして、

以下のようなコードで、
自分好みの表(そちらの希望に沿ってはいません。)を作ることが可能です。
あとの表示の順番や、列の具合、抽出したい月とかはそちらの希望するよう加工編集してください。

他人が書いたコードは解読するのに苦労するとは思いますが、
参考になれば。

参考サイト>>
構造化プログラミングに挑戦しよう！
仕様要件からコードの組み立てを考える。

他にもいいサイトがある気がします。
探してみてください。
※文字数制限に引っかかったため、一部削除しました。

コードを修正しました。
コンパイルはしてみましたが、
動作確認はしてません。
参考になれば。

ExcelVBA
1'ピボットテーブルを使った集計サンプル　Ver.0.90
2Option Explicit
3
4Sub メイン()
5    Dim wshData As Worksheet
6    Dim wshResult As Worksheet
7
8    Set wshData = Worksheets("日報")
9    Set wshResult = Worksheets("集計")
10    集計 wshData, wshResult, "日付", "氏名,場所"
11    集計 wshData, wshResult, "場所", "氏名", False
12End Sub
13
14Private Sub 集計( _
15        ByRef wshOld As Worksheet, _
16        ByRef wshNew As Worksheet, _
17        ByVal strSideItem As String, _
18        ByVal strTopItem As String, _
19        Optional ByVal flg As Boolean = True)
20    Dim rngTopleft As Range
21    Dim pvtMyTable As PivotTable
22
23    'ピボットテーブルで集計
24    Set pvtMyTable = GetResult(wshOld, strSideItem, strTopItem)
25    '書き出し位置の取得
26    Set rngTopleft = GetTopLeft(wshNew, flg)
27    '集計結果を様式に沿って出力
28    ResultOutput pvtMyTable, rngTopleft, flg
29End Sub
30
31'ピボットテーブルで集計
32Private Function GetResult( _
33        ByRef wshSource As Worksheet, _
34        ByVal strSideItem As String, _
35        ByVal strTopItem As String) As PivotTable
36    Dim pvtCache As PivotCache
37    Dim pvtTable As PivotTable
38    Dim f As PivotField
39    Dim rngSourceData As Range
40    Dim rngWorkCellRange As Range
41    Dim v As Variant
42    Dim wsh As Workbook
43
44    'セル範囲、ピボットテーブルの取得
45    Set wsh = ThisWorkbook.Worksheets("作業用")
46    Set rngSourceData = wshSource.UsedRange
47    On Error GoTo ErrHandler
48    Set pvtTable = wsh.PivotTables(1)
49    On Error GoTo 0
50
51    'ピボットテーブルでの集計
52    With pvtTable
53        '初期化
54        .ClearTable
55        '項目の配置
56        .PivotFields(strSideItem).Orientation = xlRowField
57        For Each v In Split(strTopItem, ",")
58            .PivotFields(v).Orientation = xlColumnField
59        Next
60        .AddDataField .PivotFields("執務時間")
61        '小計行の非表示化
62        For Each f In .PivotFields
63            f.Subtotals(1) = False
64        Next
65    End With
66
67    '返り値のセット
68    Set GetResult = pvtTable
69    
70    Exit Function
71
72    'エラー回避処理（ピボットテーブルがシート上に未作成の場合は新規に作成）
73ErrHandler:
74    Set pvtCache = wsh.Parent.PivotCaches.Create( _
75                   SourceType:=xlDatabase, _
76                   SourceData:=rngSourceData)
77    Set rngWorkCellRange = wsh.Range("A1")
78    Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=rngWorkCellRange)
79    Resume Next
80End Function
81
82'書出し位置の取得
83Private Function GetTopLeft( _
84        ByRef wsh As Worksheet, _
85        ByVal flg As Boolean) As Range
86    Dim c As Range
87    
88    With wsh.UsedRange
89        If flg Then
90            .Clear
91            Set c = .Cells(1)
92        Else
93            Set c = .Cells(Rows.Count + 1, 1)
94        End If
95    End With
96    Set GetTopLeft = c
97End Function
98
99'集計結果を様式に沿って出力
100Private Sub ResultOutput( _
101        ByRef pvtTable As PivotTable, _
102        ByRef rngCopyTo As Range, _
103        ByVal flg As Boolean)
104        
105    '表頭の作成
106    If flg Then
107        Set表頭 pvtTable.TableRange1.Rows(2), rngCopyTo
108    End If
109    '表側の作成
110    Set表側 pvtTable.RowRange, rngCopyTo.Offset(1)
111    '表体の作成
112    Set表体 pvtTable.DataBodyRange, rngCopyTo.Offset(1, 1), flg
113
114    '列幅をオートフィット
115    rngCopyTo.CurrentRegion.EntireColumn.AutoFit
116End Sub
117
118'*******************************************
119'表頭の作成
120'第一引数　rngFrom:転記元のセル範囲(Range)
121'第二引数 rngTo:転記先のセル範囲(Range)
122'******************************************
123Private Sub Set表頭(ByRef rngFrom As Range, ByRef rngTo As Range)
124    Dim v As Variant
125    Dim ix As Long
126
127    '元のセル範囲の値を一次配列で取得
128    '(ワークシート上の関数はセル範囲を与える仕様だが、
129    '配列も受け取れる関数があるので値（Value）を与えてもよい。）
130    With WorksheetFunction
131        v = .Transpose(.Transpose(rngFrom.Cells))
132    End With
133
134    'それぞれの値の加工
135    For ix = LBound(v) To UBound(v)
136        If ix = 1 Then
137            v(ix) = "日付"
138        Else
139            '空白でないなら
140            If Len(v(ix)) > 0 Then
141                'スペース文字で文字列を分割し最初の値を再設定
142                v(ix) = Split(v(ix), "　")(0)
143            End If
144        End If
145    Next
146    'シート上へ転記
147    With rngTo.Resize(, rngFrom.Columns.Count)
148        .Value = v
149        '選択範囲内で中央に配置の設定
150        .HorizontalAlignment = xlCenterAcrossSelection
151    End With
152End Sub
153
154'******************************
155'表側の作成
156'***********************
157Private Sub Set表側(ByRef rngFrom As Range, ByRef rngTo As Range)
158    rngTo.Resize(rngFrom.Rows.Count - 1).Value = rngFrom.Offset(1).Value
159End Sub
160
161'**********************************
162'表体の作成
163'第一引数 rngFrom:転記元セル範囲(Range)
164'第二引数 rngTo:転記先セル範囲(Range)
165'第三引数 flg:データに項目（略称）を付加するかどうかのフラグ(Boolean)
166'*************************************
167Private Sub Set表体(ByRef rngFrom As Range, _
168                  ByRef rngTo As Range, _
169                  ByVal flg As Boolean)
170    Dim vv As Variant
171    Dim v As Variant
172    Dim ixH As Long
173    Dim ixV As Long
174
175    '値を2次元配列変数で取得
176    vv = rngFrom.Value
177    '略称の付加
178    If flg Then
179        '略称の元を一次配列で取得
180        With WorksheetFunction
181            v = .Transpose(.Transpose(rngFrom.Rows(0).Cells))
182        End With
183        'それぞれの値を巡回し、値に略称をくっつけていく
184        For ixH = LBound(vv, 1) To UBound(vv, 1)
185            For ixV = LBound(vv, 2) To UBound(vv, 2)
186                If IsEmpty(vv(ixH, ixV)) = False Then
187                    vv(ixH, ixV) = Left(v(ixV), 1) & vv(ixH, ixV)
188                End If
189            Next
190        Next
191    End If
192    '転記先に転記
193    rngTo.Resize(rngFrom.Rows.Count, rngFrom.Columns.Count).Value = vv
194End Sub

売上集計しているExcelの動作を軽くしたい

↑こちらもピボットテーブルを使った方法を提案しました。参考になれば。

投稿2020/01/09 08:41

編集2020/01/22 10:38

mattuwan

総合スコア2136

ichigo15

2020/01/10 06:36

コメントありがとうございます。ご指摘のとおりだと思います。自分が作業する分には問題ありません。ですがExcelが苦手な人にもボタンをクリックするだけにしてほしいと依頼がありまして作成しております。苦手な人たちはコピーペーストさえも難しいレベルです。残念ながら再設定や再編集等、到底できないと思います。自分の知識も低いので途中でエラーや処理時間が遅い原因が分かりません。可能でしたら教えて頂けますでしょうか。よろしくお願いいたします。

ichigo15

2020/01/14 11:25

コメントありがとうございます。マクロファイルのあるPCが本日は手元にない為、教えていただいたことはまだ試せておりません。明日以降に改めて試してみようと思います。 ②について教えて頂きたいのですが様式の表のように「場所+時間」をピポッドで表示するにはどうのようにしたらよいのでしょうか？時間だけの集計表は作成できますが私の知識では様式のようにする方法が思いつきません。この表はいつ誰がどこで何時間、作業したか管理している表です。場所の表示はマストとなります。それと、「マクロで自動でやってもらうだけ」とはどの部分のことなのでしょうか？ピポッドで表を作成した後（並べ替え等）の作業のことでしょうか？申し訳ございませんが教えて頂けますでしょうか？

ichigo15

2020/01/14 11:55

私の知識ではピポッドテーブルはこのようになってしまいます。（質問事項の図をご参照ください）

ichigo15

2020/01/17 03:43

表の様式は管理上変更できません。表の様式をピポッドで作成する方法がありましたら教えて下さい。

ichigo15

2020/01/20 11:27

通常の作成手順に沿って、マクロを作成してました。ピポッドの結果をこんな風に用いてマクロを組んでいくとは思いつきませんでした。処理時間は一瞬でした。コードもスッキリしていて、自分のがごちゃごちゃしていて恥ずかしいです。お言葉に甘えて、教えて頂いたコードを参考に加工編集させていただければ幸いです。マクロにコメントを入れて下さりありがとうございます。まだ分からないコードがあるのですが、もう少し自分で勉強してみようと思います。どうしても分からない場合は別途質問しても大丈夫でしょうか。

mattuwan

2020/01/20 13:35

どんどん、質問して知識をふやしてください。ただ、特定の回答者に負担をかけるような聞き方はやめてくださいね。こちらも、パソコンの前に座らない日が多々あるので、回答出来ないこともあるので、過度の期待をされても困ります。暇があれば、もうすこしバージョンアップしたいなーとは思ってます。こちらも、練習なので、何度か一から書き直すようなことをしています。

ichigo15

2020/01/24 09:04

mattumanさん色々とありがとうございました。時間かかりましたが理解することができました。新しいコードも時間かかるかもしれなませんが勉強させて下さいまた分からない場合は別途質問いたします。

行動規範の内容に同意します